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Abstract 


This program was specifically oriented toward the demonstration of the 
feasibility of using two dimensional recursive digital filters for subjective 
image processing applications that require rapid turn around. The concept of 
the use of a dedicated minicomputer for the processor for this application was 
also to be demonstrated. The minicomputer used was the HP1000 series E with a 
RTE II disc operating system and 32K words of memory. A Grinnel 256 X 512 X 8 
bit d* splay system wa« used to display the images. 

Sample images were provided by NASA Goddard on a 800 BP I , 9 track tape. 
Four 512 X 512 images representing 4 spectral regions of the same scene were 
provided. These Images were filtered with enhancement filters developed during 
this effort and returned to NASA Goddard for further analysis. 

1.0 INTRODUCTION 

The goal of this program was to develop algorithms to be used in the 
laboratory on a near real time basis to enhance the capability of a trained 
observer to obtain geologically interesting information from Landsat satellite 
imagery. Each Landsat Image Is recorded with 4 separate spectral bands: 3 in 
the visible and 1 In the Infrared. Thus each scene to be processed is composed 
of 4 images. Four such Images of a scene of interest was provided by NASA 
Goddard as test Images for the program. Each image was provided with 512 rows 
of 512 pixels per row and 8 bits per pixel. 

The objectives of the program were to develop software to implement 
previously designed two dimensional recursive digital filters on the Department 
of Electrical Engineering^ HP1000 computer system [3]. These filtering 
algorithms were to be used in an evaluation of the feasibility of their use to 






aid the extraction of geologically Interesting data from Landsat Images. The 
sample Images were to be processed and provided to NASA Goddard for analysis and 
evaluation. 

It was not an objective of this program to approach near real time 
performance because there was no opportunity to optimize the system hardware for 
this purpose. A pipeline or array processor would have to be added to Improve 
the computational capability of the system. However, the performance of the 
system could be used to assess feasibility of further research and development 
In this area. 

2.0 BACKGROUND 

Digital filters can be classified as being of two basic types: transform 
domain filters and time or spatial domain filters. The filtering process Is 
performed in the frequency or transform domain with transform domain filters. 
The transforms of the signal to be filtered and the Impulse response of the 
desired filter are multiplied to form the transform of the output signal. The 
Inverse transform of the result provides the filtered output signal. Thus any 
filtering operation requires two transform operations and a multiplication 
operation. The Discrete Tourier (DFT) Is commonly used for most transform 
domain filtering operations. The Fast Fourier Transform (FFT) algorithm 
provides a means of implementing the DFT In a computationally efficient manner. 
Time or spatial domain digital filters do not require a transform process. The 
filtering is done by taking a weighted average of input and past output values 
to compute the current output. 

There are basically two types of image enhancement: subjective image 
enhancement and image correction. In subjective image enhancement, the object 
is to process the image in such a way as to make an improvement in its 
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appearance or ability to transfer Information In some way. If this type of 
Image enhancement Is of Interest, the user should have available a multitude of 
general purpose Image processing functions. These would Include (but not be 
limited to) low pass filters, high pass filters, low and high frequency 
enhancement filters, line enhancement filters and line suppression filters. 
Most of these filtering operations can effectively be accomplished by two 
dimensional spatial domain digital filters. There Is no Inherent need to obtain 
the DFT In the filtering process. 

Spatial domain filtering using digital recursive filters offers savings In 
computation time and core requirements over the use of transform methods to 
achieve the same filtering process [1], This Is accomplished for many filtering 
operations with no sacrifice In the quality of the output. Therefore, It is 
advantageous to use recursive digital filters for those functions for which 
appropriate filtering algorithms can be developed. 

Spatial domain filtering using digital nonrecursive filters offer 
advantages over both recursive digital filters and FFT digital filters when the 
number of filter coefficients are relatively small. However, the filters 
available that meet this requirement are limited. For this reason, nonrecursive 
digital filters can only be applied to special cases for use in near real time 
processing. In general, it requires a greater number of coefficients to realize 
a particular Impulse response for nonrecursive digital filters than for 
recursive digital filters. 

Image correction requires a much more complicated filtering process In 
general than does subjective image processing. The object Is to make 
corrections for distortion, blurring, smearing, etc., that occured while the 
image was being formed. This requires the approximation of a filtering function 
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which is the inverse of the modulation transfer function (MTF) of the Imaging 
process. It Is usually necessary to make modifications for the phase as well as 
the magnitude of the MTF. The resulting filtering requirements are often very 
complicated and the design of the required digital filter Is not a trivial 
process. 

The application of the two dimensional recursive digital filters to Image 
processing and other two dimensional data has been hampered by two problems: 
stability and synthesis. The synthesis problem Is the problem of expressing the 
two dimensional Z-Transform of the desired impulse response In closed form and 
thus determining the filter coefficients. The stability problem Is Important 
because the recursive filter requires feedback of past output values and 
therefore can become unstable. Research results obtained on both of these 
problems by the authors have demonstrated that two dimensional recursive digital 
filters are very practical for Image processing applications [2,3]. 

3.0 MATHEMATICAL THEORY 

The theoretical basis for the two dimensional ZW-Transform [4] involves the 
theory for sample data systems. Given discrete samples of a two dimensional 
function, f(x,y) with sampling Increments X and Y respectively, the ZW-Transform 
for the function is defined by 

oo oo 

F(z,w) y f(mX,nY)z" m w" n (3.1) 

m=- oo n=- oo 

If the function Is an Imaqe, then the problem can be set up so that m and n have 
no negative values and the range of m and n is finite. We further restrict the 
problem to the case where X and Y are constants. Then, if we use the notation 
f(m,n) to represent f(mX,nY), we have 


Page 6 


''...Hi jp : 


M N 

F(i,w) ■ £ £ f(m ,n)z*V n (?.2) 

m»0 n«0 

as the ZW-Transform for the Image function, f(m,n), which has (M + 1) columns 
and (N + 1) rows. 


Consider the case where we have an Input Image with samples f(m,n) and we 
wish to filter this Image to obtain an output Image with corresponding samples, 
g(m,n). The samples of the Impulse response of the desired filter are given by 
h(m,n). The range of m and n for the output Is the same as for the Input. 
Thus, the ZW-Transform of g(m,n) Is given by 


G(z,w) 



g(m,n)z" m w” n 


( 3 . 3 ) 


m*0 n=0 

If we restrict the impulse response such that m and n cannot be negative 
causal system), we can write the ZW-Transform for the Impulse response as 


(a 


H(z,w) 


s 


OO 00 

zz 


m=0 n=0 


h(m,n)z" m w" n 


( 3 . 4 ) 


In general, the ZW-Transform for the impulse response Is an Infinite 
series. In order to implement the spatial domain filter, we must find a closed 
form expression for H(z,w) such that 
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H(z,w) 
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(3.5) 


Some of the coefficients, aj K and bj K may be zero. The convolution 
property of the ZW-Transform gives the relationship resulting from the 
convolution of f(m,n) and h(m,n) which Is the filtering process 
G(z,w) « H(z,w)F(z,w) (3.6) 

If we use the closed form of H(z,w) and restrict bgg to be equal to one and 
write the resulting equation for a single output value g(m,n), we obtain the 
difference equation for the causal filter 


g(m,n) “X! X a JK f ( n, - J ‘ n - K) "XX b JK g(m-J ,n-K) (3.7) 


J=0 K=0 


J=0 K=0 
J+K>0 


If L is relatively small (in practice, L Is usually less than 10 for recursive 
digital filters), equation (3.7) represents a very efficient algorithm for 
filtering images. Equations (3.5) and (3.7) may also represent a nonrecursive 
filter If all b JK except bgg are equal to zero. 
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4.0 STABILITY ANALYSIS 

Nonrecursive digital filters are Inherently stable. Since there Is no 
feedback of past output values, the Impulse response has finite duration. Each 
output value Is a finite sum which Is always bounded If the Input Is bounded. 

The stability problem for one dimensional digital recursive filters Is 
straight forward. The roots of the denominator polynomial In the closed form of 
the one dimensional Z-Transform for the filter Impulse response function must 
have magnitudes less than one. Stability analysis Is therefore reduced to 
finding roots of nth degree polynomials with real, constant coefficients [5]. 
Stability analysis iz not straight forward for the two dimensional problem 
because a two variable polynomial Is not generally factorable Into distinct 
roots. When the polynomial In the denominator of the two dimensional 
Z-Transform of the Impulse response Is factorable Into distinct roots, the 
stability analysis procedure Is the same as for the one dimensional problem. 

The two dimensional stability problem Is very complicated if the polynomial 
in the denominator Is not factorable Into distinct roots [6]. Efforts by other 
researchers have been directed toward examining regions of roots for two 
variable polynomials. The developed procedures are computationally feasible 
only for very simple filters. An alternate method of assessing stability for 
one dimensional digital recursive filters Is to make a state space 
representation of the filter [7]. Then the filter is stable if the eigenvalues 
of the state transition matrix all have magnitudes less thai one. Previous 
research has been directed toward developing the two dimensional equivalent of 
this procedure [2]. A pseudo-state variable representation Is chosen because of 
difficulties in finding a true state space representation [8]. This difficulty 
Is caused by the bi variance of the transfer function and by its causality. The 
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resulting matrix equation has two pseudo-state transition matrices. 

Previous results have shown that the corresponding filter Is unstable If 
aqy of the eigenvalues of either of these matrices have magnitudes greater than 
or equal to one or If any of the eigenvalues of the matrix sum have magnitudes 
greater than or equal to one. Reprints of papers presenting these results are 
Included as In [2]. 

In practice, these constraints have been found to be very useful In that 
all tested filters that were known to be unstable were Identified as such by the 
procedure. Conversely, all filters which were known to be stable met the 
criteria for stable filters and were not identified as unstable. 

5.0 SYNTHESIS 

The synthesis of nonrecursive digital filters is not a major effort in the 
proposed research. Several simple nonrecursive digital filter designs may be 
found in the literature [9]. It would be appropriate to evaluate these designs 
with regard to application to near real time processing of Landsat satellite 
data. However, this was not a part of this program. 

Often it is possible to express a desired two dimensional recursive digital 
filter as the product or sum of two one dimensional digital filters. That is 
the two dimensional Z-Transform of the digital recursive filter can be expressed 
as the product or sum of two one dimensional Z-Transforms. In either case, the 
two dimensional synthesis problem is reduced to the synthesis of two one 
dimensional filters. However, it is not possible to design sum separable or 
product separable digital recursive filters for all applications. For these 
applications, the design of the required two dimensional digital recursive 
filter is considerably more complicated. 
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Many Imaging systems have a natural circular symmetry. In general , the 
optical transfer function of a circularly symmetric Imaging system Is circularly 
symmetric. Also, It Is usually desirable t: perform Image processing where the 
processing Is uniform with respect to direction. The natural consequence Is 
that filters with circularly symmetric Impulse response functions are generally 
very desirable for Image processing. The relationship between circular symmetry 
of the Impulse response and the frequency response dictates that the design 
requirement Is for these filters to have a circularly symmetric frequency 
response [10]. 

Previous research efforts have led to a synthesis technique which yields 
two dimensional recursive lowpass, hlghpass, low frequency boost and high 
frequency boost recursive digital filters that are very close to being 
circularly symmetric whrn the cutoff frequencies are approximately one half the 
Nyquist frequency [3,11]. Some degradation Is observed as the cutoff frequency 
approaches either the Nyquist frequency or zero. 

In the design procedure, the squared magnitude characteristic of the 
desired circularly symmetric filter is chosen in the Laplace Transform domain. 
The bilinear transformation is then used to map the squared magnitude 
characteristic into the two dimensional Z-Transform domain. The pseudo-state 
space representation for the corresponding two dimensional Z-Transform Is 
formed. The eigenvalues of the matrix sum of the two pseudo-state transition 
matrices are obtained. These eigenvalues occur In reciprocal pairs. The 
eigenvalues with magnitudes less than one are then used as roots of a 
denominator polynomial with distinct roots to form the two dimensional 
Z-Transform of the desired filter. 
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Note that this design procedure always ensures a stable filter. Stability 
analysis Is simple because the denominator of the ZW - Transform Is a product 
separable. Also note that no restrictions are placed on the numerator 
polynomial. The;. Is. It Is not necessary for the numerator polynomial to either 
be product separable, sum separable or minimum phase. Examples of stable two 
dimensional recursive filter designs are given In [12]. 

Another problem of Interest In Image processing Is to filter with a one 
dimensional filter with the orientation of the filter specified and independent 
of the sampling direction. This type of filter would be useful for enhancing or 
suppressing linear features, for system noise suppression or for Image 
correction (l.e. , linear smear). However, any one dimensional digital recursive 
filter which is rotated becomes a two dimensional digital recursive filter with 
associated problems in stability and synthesis. Constraints with regard to 
stability of rotated digital filters have been developed [13,?']. However, the 
problems associated with the actual synthesis of rotated recursive digital 
filters have not been adequately addressed. This Is a problem of interest to 
this research program. However, it was not pursued during this effort. 

6.0 IMPLEMENTATION 
6.1 Implementation Considerations 

Recursive digital filters have many very desirable features that make them 
advantageous for real time or near real time image processing applications. In 
the practical application of recursive digital filters, only a small number of 
rows of the image to be processed are required to be stored in the computer at 
one time. Three rows of storage plus three rows of storage for each pair of 
complex poles In the transfer function to be realized are required. Thus a 
filter with two poles and two zeros would require the storage of the equivalent 
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of six rows of the Input Image. A filter with four poles and four zeros would 
require the storage of the equivalent of nine rows of the )i y ut Image. 

Most Image filtering requirements may be met with a filter having no more 

than four i.ros and four poles. Therefore, an algorithm which allows up to four 

zeros and four poles Is practical. Such a filter would still require on’y 

slightly more than 9216 storage locations to filter a 1024 by 1024 Image. Some 

additional storage would be required to store the code for the algorithm 

Including Its interface to data handling algorithms. Thus It Is quite feasible 

to use recursive digital filters to filter Images up to 1024 by 1024 using a 16 

bit minicomputer with only 64k words of storage. If In addition a pipeline or 
« 

array processor Is used to Implement the recursive digital filter Itself, 
extremely fast processing can be accomplished. In fact, the processing time may 
be limited by the time required to transfer the data from and back to the 
storage medium during the actual filtering process. 


Recursive digital filters typically require fewer data transfer operations 
to filter a given image than FFT filters. This is particularly true for very 
large images. The FFT filtering algorithm requires that the Image be 
transformed by row and then by column. If the image is too large to fit In the 
computer at one time, the FFT algorithm becomes inconvenient to use for 
filtering Images. One method commonly used to overcome this difficulty Is to 
filter the Image in blocks which are small enough to fit into the computer and 
then fit these filtered blocks back together to form the output Image. 
Considerable overlap of these blocks Is required to avoid artifacts due to 
periodic convolution. Average levels between blocks also have to be adjusted to 
avoid a checkerboard effect. Another method commonly used is to transform the 
image by rows, transpose the image and then transform the image by columns [15]. 
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Thlr. procedure adds two transpose operations to each filtering operation. The 
result Is that In the practical use of filtering large Images, recursive digital 
filters are very significantly more efficient and require far less time to 
Implement than FFT filters. 

Recursive digital filters Inherently have nonlinear phase characteristics. 
This is true because of feedback of past output values. However, linear phase 
car be obtained by filtering the Image twice [3]. The Image Is filtered 
starting from the first row, first pixel and ending with the last row, last 
pixel. Then the Image Is filtered backward starting with the last row, last 
pixel and ending with the first row, first pixel. The result Is a filter 
transfer characteristic which is the magnitude squared of the original 
characteristic. Thus, the filter with four poles and four zeros effectively has 
eight poles and eight zeros and linear phase when this procedure Is used. 

6.2 Transient Response 

The use of past values of the output to compute the current output value 
results in the equivalent of long term storage of Information about past Inputs 
for recursive digital filters. Thus, such filters have an Infinite Impulse 
response (HR). In addition, the beginning of each scan line In an image 
represents a transient which can cause very undesirable results If the 
implemented filter has a long term transient response. If this situation is not 
handle properly, then two dimensional recursive digital filters will give very 
poor results. This is particularly true for high frequency boost or highpass 
filters. 

The approach use to minimize this problem is to place the filter In a 
stable state with an assumed input within the range of the image data. The best 
assumed input would be the expected value of the Input Image intensity. 
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However, this Is usually not available. An approximation Is obtained by 
averaging the Intensity values of the middle row of the 1m*ge. The final value 
theorem [5] Is then used to determine the stable state for rach of the output 
stages for the filter. The expected values approximation Is then used as the 
Initial condition Input for each scan line and the stable state output Is used 
as the Initial condition output for each filter stage. Thus, If the Initial 
Input Is the same as the assumed Initial condition, then no transient response 
occurs. 

In practice, the procedure outlined above Is simple to Implement and add 
very computations to the filtering process. However, additional Improvement can 
be obtained by extending the Image by using a reflection of future pixel values. 
Typically as few as 5 values produces very good results such that no transient 
response artifacts may be observed with most filter designs. 

6.3 Implementation Algorithms 

Equation 3.7 provides the fundamental algorithm for the two dimensional 
recursive digital filter. A straight forward approach Is to Implement the 
filter directly as provided. However, consideration must be given to roundoff 
error (the HP1000 compute- uses 32 bit floating point arithmetic) and 
computational efficiency. In addition, the use of complex numbers should be 
avoideu. Therefore, the fundamental stage for the filters was selected to be a 
second order stage with L equal to 2 In (3.7). Higher order filters may be 
implemented using multiple stages. This also allows combinations of filters 
such as a low pass filter for noise removal and a high frequency boost filter 
for edge enhancement. 
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In writing the actual algorithm, care was taken to use one dimensional 
arrays and to avoid transferring data between arrays when possible. Thus a 
computationally efficient algorithm was developed. 

The fact that the HP1000 series E uses a software floating point 
arl thematic processor and only has a total of 32 K words (64 K bytes) of memory 
provided a severe hardware limitation. This system has just recently been 
upgraded to the series E RTE-IVB with an additional 64 K words of memory and a 
hardware floating point processor. Thus the performance of the Image processing 
software should be very significantly Improved with these hardware changes. 

In addition to the Implementation considerations described above, research 
was conducted with regard to devising special algorithms which can be used in 
parallel or pipeline architectures to approach real time Image processing. 
Aopendix A and B provide details on this effort. Appendix C and D gives 
documentation of the software developed. 

7.0 APPLICATIONS 
7.1 Dynamic Range Comnresslon 

Electro-optical sensors respond to reflected or emitted radiation. A 
typical electro-optical imaging system uses a single detector or an array of 
detectors In a scanning mode to form the Image. If the signal of Interest Is 
the reflected radiation such as Is the case for visible imaging systems, the 
detected signal is made up of two components: the illumination component and 
the reflection component. Infrared sensors typically detect radiation emitte< 
by objects. It is typical that the available dynamic range of electro-optical 
imaging systems is several orders of magnitude. On the other hand, display 
systems are usually limited to at most two orders of magnitude and human 
observers can only detect approximately 50 different intensity levels [16]. 
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Therefore, It Is not possible to directly display all Information obtained In 
many Images. 

The Illumination component of optical Images or the overall background 
radiation for Infrared Images generally has low spatial frequency content but 
may havp a wide dynamic range [17]. This Is the case where shadows exist In 
optical Imagery or hot spots occur In Infrared Imagery. The reflected component 
or the emitted component of th? .a al Is usually of priority Interest and 
generally has higher spatial Vrequency content. This signal Is formed by the 
different emisslvlty or reflectance of each Item In the Image. 

The detected signal Is therefore a product of the Illumination or 
background radiation and the reflectance or emisslvlty at each point In the 
image. Homomorphic filtering using spatial domain digital filters provides an 
effective means of dynamic range compression by providing the capability to 
suppress the lower frequency component of the signal (Illumination or background 
radiation component) and enhancing the higher frequency component of the signal 
(reflected or emitted component of the signal) [18]. This procedure Is 
accomplished by taking the logarithm of the Input signal, filtering with a high 
frequency boost filter and exponentiating the resulting output. 

7.2 Subjective Image Processing 

A simple design procedure can be used to allow an untrained operator to 
design digital filters for subjective image processing. For example, a low pass 
or high pass filter may be specified by the cutoff frequency and the number of 
poles desired [3]. A high frequency enhancement filter or a low frequency boost 
filter may be specified by a break frequency and the magnitude of the boost. 
Thus, the user (Joes not have to learn filter theory or be concerned with signal 
to noise considerations, etc. to design the desired filter. This is a very 


valid approach for subjective Image processing because decisions about the type 
of filter desired are usually made based upon experience. Thus the user should 
be provided with several options which can oe Implemented with a minimum of 
effort and without special training. Recursive digital filters are well suited 
for this application. 

7.3 Bandwidth Optimization 

If an Imaging system Is used In an Interactive mode, digital filters can be 
used to effectively change the bandwidth of the Imaging system to meet a 
particular application. Thus under low signal to noise operating conditions, 
the operator can decrease the bandwidth of the system In an attempt to improve 
his ability to discern details of an object of interest. This can be 
accomplished with spatial digital filters simply by changing filter 
coefficients. No change in hardware is required. 

7.4 Interpolation 

Often it is desired to change the size of an image in image presentation or 
display operations. This usually requires a change In the number of rows or 
columns of the subject image. In changing the size of the Image, the sampling 
theorem must be considered. Artifacts In output Images after the use of a 
simple interpolation scheme are quite often due to aliasing. 

An image is usually stored in discrete form. That is, only samples of the 
image are available in the form of pixel elements. Thus Interpolation really 
involves reconstructing the image to a continuous form and then resampling at 
the new desired intervals. The ideal interpolation algorithm would involve a 
reconstruction filter based upon the sampling theorem [5] and a sampling 
algorithm to resample the image at the desired intervals. However, It Is not 
computationally feasible to use this approach. Therefore, it is common practice 


to use a simple algorithm such as nearest neighbor, bilinear or constralnea 
polynomial Interpolation for Image processing requirements. These algorithms 
all result In aliasing when either the number of rows or columns Is decreased. 
If the number of rows or columns Is Increased, these algorithms add undesired 
noise to the output Image which Is Image dependent [16]. 

A means of Improving the results of these Interpolation schemes is to use 
prefiltering to avoid aliasing and/or post filtering to remove undesirable 
additive noise. The results using this procedure can be made to be very close 
to the ideal reconstruction filter Interpolator with the proper combination of 
filtering and a simple Interpolation algorithm. The use of recursive digital 
filters which have been shown to be considerable more efficient computationally 
than the FFT algorithm for Image processing makes this procedure feasible. For 
example, the bilinear Interpolation algorithm can effectively be combined with 
an antialiasing filter when needed to give results which are very significantly 
improved over the use of the bilinear Interpolation algorithm alone. 
Computationally, such a scheme would compare very favorably to a constrained 
polynomial interpolation algorithm and would give superior results for many 
images. 

7.5 Image Registration, Classification and Evaluation 

Image registration, classification and evaluation schemes generally do not 
take advantage of digital filtering. In general, relatively simple schemes are 
used with human interaction playing a very important role. This is partially 
true because of the inconvenience of using filtering with current techniques 
which employ the FFT algorithm and partially because the feasibility of using 
spatial filtering to improve image registration, classification and evaluation 
has not been demonstrated. 


Two dimensional recursive digital filters have advantages which make them 
very attractive for use In exploring the feasibility of using spatial filtering 
to Improve these procedures. The filters can be designed with only a small 
number of parameters specified by the user (usually no more than two parameters 
must be specified). The actual filtering process requires significantly fewer 
computations and data transfers than the FFT algorithm and Image size is not 
constrained to power of 2. Thus, very fast turnaround can be achieved. 

With very fast turnaround and with the availability of various types of 
filters, the exploration of the use of filtering for image registration, 
classification and evaluation becomes far more practical. If spatial filtering 
proves beneficial, then the implementation can be done with only a small 
sacrifice in time and without the use of a very large computer system. Thus two 
dimensional recursive digital filters may be very beneficial to Image 
registration, classification and evaluation. In practice, the use of such 
filters may prove to be very beneficial In automating these vital procedures. 

3.0 IMAGE PROCESSING FACILITIES 

The Department of Electrical Engineering at A & T State University has a 
HP1000 Series E computer system and the University has a DEC10 computer system. 
Both of these computer systems were used with this program. 

The HP1000 is a 16 bit minicomputer system with 32k words of core, a 14.6 
megabyte disk drive and a 9 track tape drive. The core will be extended to 192k 
bytes and the CPU is being upgraded to series E with the RTE- IVB operating 
system. This upgrade will be completed by the end of February, 1981. The 9 
track system can be used to transfer data from and to the DEC10 computer system. 
A Grinnell Model GMR-27 display image system is also available. This display 
can display an image with 256 rows and 512 pixels per row with 8 bit accuracy. 


Plans also Include additional graphics capability and a full color display 
system. 

The DECIO computer system Is an Interactive system with a 36 bit word 
length and double precision arithmetic capability. Thus, It can be used for 
stability analysis and filter synthesis and evaluation. The current DECIO 
system consist of a KL-10 central processor , 512k words of memory, 2 self 
loading tape drives a communications controller for up to 96 asynchronous dial 
drives. 

The Department of Electrical Engineering also has a HP2648 graphics 
terminal which Is connected to the HP1000 computer. This graphics terminal Is 
used for Interactive stability analysis and filter synthesis. 

9.0 IMAGE PROCESSING RESULTS 

The lack of a hard copy output capability presents considerable difficulty 
with regard to Including actual Landsat images or the processed results in this 
report. A HP9872 plotter is connected to the HP1000 computer and may be used to 
plot frequency contour and perspective plots of the actual filter used in the 
Image processing examples. However, a 35-mm camera was used to photograph the 
Grinnell display screen to obtain the examples that follows 

Figure 1 is the frequency perspective plots of a 5 magltude High Boost 
Filter with 0.2 cutoff frequency. Figure 2 is the frequency contour plot of the 
same filter. Figure 3 is file number three (3) of the Landsat Imagery tape 
received from NASA. Figure 4 shows the results of processing images with the 
filter of Figure 1 and then mapping between minimum and maximum logarithmical ly. 






Page 24 


12.0 REFERENCES 

1. Earnest L. Hall, "A Comparison of Computations for Spatial Filtering", 
Proceedings of the IEEE , Vol. 60, no. 7, 1972, pp 887-891. 

2. Wlnser E. Alexander and Steven A. Pruess, "Stability Analysis of Two 
Dimensional Digital Recursive Filters 11 , IEEE Transactions on Circuits 
and Systems , Vol. , No. 1, 1980, pp. 

3. Wlnser E. Alexander and William J. Craft, Documentation for Spatial 
Domain Filtering Package , Department of Electrical Engineering, North 
Carolina A if State University, January, 1979. 

4. Lawrence R. Rablner and Bernard Gold, Theory and Appl 1 cat Ion of 
Digital signal Processing, Prentice-Hall, Inc., Englewood Cliffs, UT 
XTT375/ ipTO-455. 

5. Samuel Stearns, Digital Signal Analysis , Hayden Publishing Co., Inc., 


6. N. K. Bose, "Problems and Progress In Multidimensional System 
Theory", Proceedings of the IEEE , Vol. 65, No. 6, 1977, pp. 824-840. 

7. Katsuhlko Ogata, State Space Analysis of Control Systems , 
Prentice-Hall, Inc., Englewood CTiffs, N. J., p. 487. 

8. E. Fornaslni and G. Marcheslni, "State Space Realization Theole for 
Two Dimensional Filters', IEEE Transactions on Automatic Control, Vol. 
ACOlt 1976, pp 484-492. 

9. E. L. Hall, Digital Filtering of Images , Ph.D. Dissertation, 

University of Missouri, Columbia, Mo. , 1971. ’ 

10. A. Papoulis, Systems and Tr ansforms with Appl 1 cations In Optics , 
McGraw-Hill Book Co. New York, N. Y., 1968, p. 140. 

11. Wlnser E. Alexander, A Study of Two Dimensional Recursive Digital 
Filters, Final Report (Naval Air 5ystems CoTr5H3 Contract No. 
N0-14-77-C-0199), School of Engineering, N. C. A T State University, 
Greensboro, N. C. , November, 1978. 

12. Winser E. Alexander and Ear-.uist E. Sherrod, "Two Dimensional 
Recursive Oigital Filters for Subjective Image Processing", 13th 
Asllomar Conference on Circuits, Systems and Computers , November, 1979. 

13. J. M. Costa and A. N. Venetsonopoulos, "Design of Circularly 
Symmetric Two Dimensional Recursive Filters", IEEE Transactions on 
Acoustics, Speech and Signal Pr ocessing , Vol . ASSP-22, NX W, T$7TT 
"pp 432-442. 

14. Dennis Goodman, "A Design Technique for Circularly Symmetric Low Pass 
Filters", IEEE Transactions on Acoustics, Speech and Signa l Proces sing , 
Vol. ASSP^eT No. 4, 1978, pp 290-304. 


Page 25 



15. B. R. Hunt. "Data Structures and Computational Organization In 

Digital Image Enhancement", Proceedings of IEEE, Vol. 60. 1972. dd 
884-887. 

16. William K. Pratt, Digital Image Processing , John Wiley and Sons, Inc., 
Somerset, N. J., 1978. 

17. Wlnser E. Alexander, "Electronic Target Enhancement In Infrared 
Reconnalsance" , Proceedings of the 1968 Air Force Science and 
Engineering Symposium . October. T968. 

18. Thomas G. Stockham, Jr. "Image Processing In the Context of a Visual 
Model", Proceedings of the IEEE , Vo 1 . 60, 1972, pp 828-842. 


j 

5 



APPENDIX A 


INVESTIGATION OF ALTERNATIVE REALIZATION TECHNIQUES 

Another aspect of thr research conducted under this contract was that of 
Investigating alternative realization techniques for not only the filter designs 
choserv but also for a more general class of filters as well. This investigation 
although as yet incomplete has resulted In some Interesting conceptual reformations 
of the filter realization problem [1], as well as the suggestion of possibly more 
computationally efficient algorithms for obtaining the filter solutions. 

The typical approach taken in realizing recursive 2 D filters is one of 
processing the filtered output directly using the forward and backward difference 
equation formulations of the filter. This approach requires that one either 
already know the Initial condition or boundary condition state of the filtered 
output (which generally is not the case), or that one uses various statistical 
estimates of what these boundary states might be in order to beqin the resursion. 

In either case the direct use of the difference equations may not result in a 
minimun number of arithmetic operations being performed in obtaining a filtered 
solution [2,3,4]. 

The approach taken in this aspect of the conducted research was one of 
formulating the complete set of simultaneous linear algebraic equations to be 
solved in order to obtain a solution which satisfies the 2 D difference equation 
description of the filter. This serves to give one a complete description of 
the constraints which must be satisfied by the filtered solution with or 
without boundary conditions imposed on the problem. 

The class of filters considered were those which possess a rational transfer 
function. Such a filter may be represented by its bivariate difference equation 


written In tensor form as: 


b ij 9 p+i ,qvj * a 1j Vi.q + j ^ 

where l*p*N, l^q^M, -m^j^m; and the double appearance of an Indice 

on a given side of the equality Implying the usual tensor notation for a 
summation over the specified range of that Indice. The so called finite 
duration Impulse response filter (FIR) Is one which satisfies bgQ*l with 
all other b^ ^=0; whereas the Infinite duration Impulse response filter (IIR) 
is one which allows nonzero g^ for l.j^O. A more formal tensor expression 
for (1) Is given by: 


0 kl . .kl f 
B pq 9 kl ~ %q V 


( 2 ) 


where l*k*N, 1*1*M, and the non-zero components of the coefficient tensors 


given by - a k-p.l-q and B pJ = b k-p,l-q ; for and 

-m-l-q^m. The 2 D filtering operation requires that one determine all the 

elements g n . given all the coefficients a.., b. ., and the input array f . 

pq i J 1 3 pq 

A solution to equation (2) will exist and be unique if there exists an 
inverse of the tensor say Cjj; with l*u*N, l*v*M. For such a case, 

the filtered solution would then be given by: 


’uv 


= CP^ A 


k'f 


uv pq kl 


(3) 


Tensor equation (2) can also be interpreted as a matrix equation with 
kl kl 

%q* and B pq ta * cen as by NM dimensional coefficient matrices with row 

index "pq", colunn index "kl"; and g^ and f^ interpreted as column vectors. 
Viewing equation (2) as such a matrix equation reveals the enormity of the 
computer storage problem encountered in attempting a solution, for if both N 


and M were typically of the order to say 512 (for a 512 by 512 pixel array) 

36 kl 

then 2 memory locations would be required for the tensor of matrix B p q alone. 

The matrix equation Interpretation of equation (2) also reveals the 

kl 

following characteristics of the coefficient matrix B pp for these selected 
digital filters: 

(a) For the "Quarter Plane" digital filter, B^ is a triangular 
matrix. Hence, the solution for the filtered array g^ 
requires no Inversion of the coefficient matrix. By a 
simple back substitution process, starting at one corner 

of the array and proceeding by rows orcolunns, the filtered 
array may be computed provided that the iteration process is 
nunerically stable. 

(b) For the "Symmetric" diagltal filter, with filter coefficients 

symmetric with respect to any diagonal passing through the 

central element bgg of the mask b^, the coefficient matrix 
kl 

B pq is symmetric. 

Among the interesting results developed during the tenure of this research 
was the fact that for square arrays N=M, and filters with ag Q , b Q0 f 0; the 
filtering problem given by equation (2) is also expressible as a matrix equation 
involving only N by N dimensional sparce coefficient matrices given by: 

m m 

LGR + I S.G T. = c PFQ + c S S.F U. (4) 

k=-m,M0 K K k=-m,M0 K K 

where c = agO^OO’ the matrix G = (g pq ) 1S the filtered array, F = (f ) is 

the input array; and the nonzero components of the coefficient matrices 

L, R, P, Q, S k , ~ k , and are given by: 


(1) For p,q such that -m-q-p-m: 

L pq =b q-p,0 /b 00; R pq =b 0,q-p /b 00 ; P pq =a q-p,0 /a 00 ; Q pq =a 0,q-p /a 00 ; 

2 2 
T kpq =b k,p-q /b 00 “ b k,0 b 0,p-q /b 00 ; U kpq =a k,p-q /a 00 ' a k,0 a 0,p-q /a 00‘ 


(1i) And finally, for p,q such that q-p=k: = 1. 

The reduction in the dimensions of the coefficient matrices shown in 
equation (4) is one of the practical reasons why one would prefer to solve 
that expression for the filtered output rather than equation (2). The 
coefficient matrices in (4) also have other appealing properties in that 
both L and R are symmetric matrices, all of the matrices have the "bandtype" 
structure in that they have but one distinct element per respective major 
or minor diagonal, and all of the matrices are relatively sparse (many zero 
elements). 

Unfortunately expression (4) is not generally solvable by using linear 
methods due to the fact that one cannot combine those matrices which premultiply 
the unknown matrix G (i.e., 1 and the S^), or those matrices which postmultiply 
G(i.e., R and the T^). It should be noted, however, that for those cases in 
which equation (4) is not solvable for G using linear methods, this does not 
imply that there exists no unique solution. It is equation (2) that dominates 
in that it is always solvable if (4) is solvable, but (2) may still be solvable 
even if (4) is not linearly solvable. Hence, from the standpoint of linear 
analysis (2) possesses more potential in solving for q than equation (4). 

rH 

There is an important class of filters for which equation (4) is linearly 
solvable, and this class is the set of filters which are product separable. 

The coefficients involved in product separable filters have the properties: 

a k,p-q^ a 00 " a k,0 a 0,p-q^ a 00 " 0 

b k,p-q /b 00 " b k,0 b 0,p-q /b 00 = 0 


• 1 


Hence, the matrices T^, and are all Identically zero and equation (4) 
reduces to: 

LGR = c PFQ (5) 

and the solution for the filtered output G given by: 

( 6 ) 


G = L* (cPFQ) R" 1 


At first glance It would appear the the computation of the filtered 
output array G Is still a formidable task due to the required Inversions 


L" 1 , and R’ 1 ; however both L, and R are Toeplitz matrices and can be Inverted 


efficiently [5], hence we have our first Instance of a possibly more efficient 
algorithm for obtaining filter solutions. 

Adding additional restrictions, it has also been determined that if the 
filter is both product separable as well as symmetric then the coefficient 
matrices L and R can be further decomposed to give equation (5) the equivalent 
expression: 

L u L 1 G R u R 1 = c PFQ (7) 

where L, and R, are lower triangular, and L and R are upper triangular matrices. 

II U II 

Expression (5) is then solvable for G using a minimum nunber of arithmetic 
operations without requiring the inversion of L and R, provided that the 
intermediate results are mmerically stable. 

Finally, for the filter problem described by expression (4), iterative 
methods of solution such as*. 

.(n)-r x „-l 


s'" +1) ■ L* 1 *k£-m,kj<0 V'"'V ■>“ * H 


( 8 ) 


where H * L* 1 (cPFQ + c.E ... Si/ u l) R 1 

k=-m,W0 K K 


*1 


as suggested as possible techniques to be applied to obtain filter solutions 
for those filters which do not satisfy the restrictions required for expressions 
(5), (6), and (7). The investigation of the convergence of such iterative 
solution techniques is the subject of current and future research. 


r-^i 
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Appendl x B 


Implementation Consideration for Two Dimensional Recursive Digital 
Filters with Product Separable Denominators. 


Introduction 

Consideration is given to the implementation of two dimensional digital 
recursive filters that have transfer functions with product separable 
denominators. This structure is of particular importance to this program 
because the design technique used for the design of approximately circularly 
symmetric filters results in a transfer function with a product separable 
denominator. We seek to derive a computationally efficient structure that may 
also lend itself to implementation with the use of a pipeline or array 
processor. 

Transfer Function 

The bivariate Z-transform for the structure of interest is given by 


H(Z,W) = 


Y Y a « rJirK 


2 2 


£ I 


b Z' J W K 

D jr w 


N(Z,W) 

( 1 ) 

n(z,w) 


We have assumed that L=2 for a single second order filter stage. We also assume 
that the denominator polynomial, D(z,w) can also be represented as 

[Evi [Iv-'l 

0=0 K =0 


D(Z,W) = 


( 2 ) 


Page 2 


We can Implement H(z.w) In cascade form 
H(Z.W) - H^Z.WjH^Z.WjHjtZ.W) 
where 

2 2 

Hitf.W) - Y. Y »jk Z ‘ J w ' KU 

J=0 K*0 

2 

H 2 (Z,W) - 1/ ]T CjZ’ J ; c 0 -1 

J=0 


(3) 

(4) 

(« 



Note that this form only requires 13 multiplies and 13 adds as compared to 17 
multiplies and 17 adds for the direct form associated with (1). The block 
diagram for this implementation is given below. 





APPENDIX C 


PROGRAM NAME: NASA 
PROGRAMMER: W.E. ALEXANDER 


TYPE: Transfer 


Source: Reloc: 

FUNCTION: .nis transfer offs and RP's all necessary modules 

for Image Processing; mounts cartridge 23 and runs NASA 1. 


FROM RTE: Run NASA 


Modules Cal led: 


SHOW 

BLDWF 

BLDIM 

WTAPE 

> DSPLY 

CURSR 

1 FDIGN 

STAB I 
DPLAM 
FILTR 
LFLTR 
HFLTR 

I RESIZ 

) IMAGE 

DINTP 

NOISE 

1 FIRO 

I 

i 

I 


Modules Run: NASA1 


Subroutines Called: 
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PROGRAM NAME: NASA1 TYPE: Program 

PROGRAMMER: W.E. ALEXANDER 

SOURCE: &NASA1 Reloc: %NA$A1 

FUNCTION: This Program is the father program for the Image 

Processing from v/hich the major modules are selected. 

Modules Called: 

OSPLY 

FDIGN 

FILTR 

RESIZ 

SHOW 

BLDIM 

NOISE 

Modules Run: 

Subroutines Called: 


FILL 


PROGRAM NAME: DSPLY 


TYPE: Program 


PROGRAMMER: DAVE JOHNSON 

Source: ADSPLY Reloc: XDSPLY 

FUNCTION: This program Displays an Image on the Grinnell Image 
Display System GMR-27. 

Modules Called: 

SCROL 

CURSR 


Modules Run: 

Subroutines Called: 

WLINE 

RLINE 

DRIVR 

RESET 

MOVEC 
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PROGRAM NAME: FOIGN TYPE: Program 

PROGRAMMER: E.E. SHERROD 

Source: AFDIGN, SFDIG1 Reloc: IFDIGN, %FDIG1 

FUNCTION: This program designs, stability tests and displays a 
filter on either HP-2648G or on the Grlnnell GMR-27. 

Modules Called: 

STAB I 
DPLAM 
FIRO 
PLOTV 

Data Hie Created: 

COEFFS 

DATA1 

Subroutines Called: 

LPFLT 

BPFLT 

BSTFT 

TDLPF 

ROTAE 

FIR 
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PROGRAM NAME: STAB I TYPE: Program 

PROGRAMMER: E.E. SHERROD 

Source: ASTABI Reloc: XSTAB I 

FUNCTION: This Program evaluates the Recursive Filter Stability 
Characteristics. 

Modules Called: 

Subroutines Called: 

STABT 

PRTN 


PROGRAM NAME: DPLAM TYPE: Program 

Source: 4DPLAM, &DPLA1 Reloc: %DPLAM, SDPLA1 

PROGRAMMER: E.E. SHERROD 

FUNCTION: This program displays the Filter Characteristics. 

Modules Called: 

COEFFS 

DPLA1 

Subroutines Called: 

ZWC 

CONTR 

SET3D 

PLT3D 

SET2U 

PLT2D 


PROGRAM NAME: FIRO 
PROGRAMMER: E.E. SHERROD 
Source: 4FIR0 


TYPE: PROGRAM 


Reloc: %FIRO 

FUNCTION: This program designs Non-Recursive FIR Filters. 

Modules Called: 

Subroutines Called: 

BESJ 

BESIO 


PROGRAM NAME: PLOTV 


TYPE: Program 


PROGRAMMER: E.E. SHERROD 

Source: &EES3 Reloc: %PLOTV 

FUNCTION: This program displays Filter Characteristics on the 
Grinnell Display GMR-27. 

Modules Called: 

DATA1 

Subroutines Called: 


DVECT 


PROGRAM NAME: FILTR 
PROGRAMMER: E.E. SHERROD 


TYPE: Program 


Page 


Source: &FILTR Reloc: %FILTR 

FUNCTION: This program schedules Linear or Homorphic 
filtering of Images. 

Modules Called: 

LFLTR 

HFLTR 

SHOW 

BLDWF 


Subroutines Called: 


PROGRAM NAME: BLDWF TYPE: Program 

PROGRAMMER: OAVE JOHNSON 

Source: &BLDWF Reloc: XBLDWF 

FUNCTION: This program creates and maintains an Image 

work file named WF0000 with pixel values stored 
as 15-bit real numbers. 

Modules Called: 

DIREC 

WFOOOO 

Subroutines Called: 

I CMPM 




PROGRAM NAME: LFLTR 


TYPE: Program 


PROGRAMMER: E.E. SHERROD 

Source: &LFLTR * Reloc: %FILTR 

FUNCTION: This program does Linear Filtering using Spatial Domain 
Recursive Digital Filters. 

Modules Called: 

COEFFS 


Subroutines Called: 



Page 12 


PROGRAM NAME: HFLTR TYPE: Program 

PROGRAMMER- E.E. SHERROD 

Source: 4HFLTR Reloc: XHFLTR 

FUNCTION: This program performs Homomorphic Filtering using 
Spatial Domain Recursive Digital Filters. 

Modules Called: 

COEFFS 

Subroutines Called: 

WFINT 

READL 

RITLN 

HFILT 

CLSWF 


PROGRAM NAME: RESIZ 


TYPE: Program 


PROGRAMMER: W.E. ALEXANDER and RICHARE MuORE 

Source: &RESIZ R ELOC: XRESIZ 

FUNCTION: This program allows the user to scale an Image 
and change an Image from 8-blts to 15-bits and 
vice versa. The resizing of an Image Is being 
developed. 

Modules Called: 

LFLTR 

DINTP 

TRMGN 

LBRSZ 

BLDWF 

Subroutines Called: 

TRMGN 

BLANX 

SPCHR 

CKFLD 

WFINT 

READL 

XYFLT 

CLSWF 

READL 

RITEL 


PROGRAM NAME: SHOW 


TYPE : Program 


PROGRAMMER: DAVE JOHNSON 

Source: ASHOW Reloc: %SH0W 

FUNCTION: This program displays an Image from the work 
file onto the Grlnnell System GMR-27. 

Modules Called: 

WF0000 

Subroutines Called: 

READL 

WLINE 

CLSWF 


SiMt ..mihrt/ laH'-minir- n 


PROGRAM NAME: BLOIM 
PROGRAMMER: DAVE JOHNSON 


TYPE: Program 


Source: &BLDIM Reloc: XBLDIN 

Loadfile: LBLDIN 

FUNCTION: This program constructs an 8 or 15-bit image from 
magnetic tape, disc, GMR-27 display or work file. 

Modules Called: 


WF0000 

DIREC 

Subroutines Called: 

MVW 
R0T8 
DC ODE 
DRIVR 
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PROGRAM NAME: NOISE TYPE: Program 

PROGRAMMER: E.E SHERROD 

Source: ANOISE Reloc: XNOISE 

FUNCTION: This program add Gaussian Noise to an Ima-je with 
user defined Mean and Standard Deviation from a 
Gaussian Noise disc file. 

Modules Called: 

BLDWF 

Subroutines Called: 

READL 

RITEL 

CLSWF 



LOAD FILES 


T a b1e of Content: 
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LDIREC 1 

LWTAPE 1 


LDPLAM 
LPLOTV 
LFDIGN 
LBLDIM 
LLFTR- 
LHFTR- 
LSHOW- 
LFIRCI- 
L IMAGE 
LRESIZ 
LDINTP 
LBLDWF 
LDSPLY 
LCURSR 
NASA-- 




PROGRAM FILES 
Table of Content: 

Page 

&NASA1 7 

4DSPLY 9 

aCURSR 12 

&ICMPW 13 

&RESET 13 

ARLINE 14 

AMOVEC 15 

& I MAGE 16 

&SPAGE 23 

ARESIZ 24 

AR0T8 33 

STRMGN 34 

4LBRSZ 37 

&WFINT 39 

ADINTP 42 

&WTAPE 44 

AEES3 47 

&DPLAM 48 

&DPLA1 52 

&FDIGN --- 60 

&BLDIM 70 

&LFLTR -76 

&HFLTR 82 

ASHOW 88 

AFIRO 89 

&WINDO 92 

ABES 1 0 92 

ABESJ 93 

&BLDWF 95 

&SCR0L 98 

AWL INE 99 

ADR I VE 100 

AFD1G1 102 

ASTABI -105 

&FILTR 117 


LDIREC 1*00004 IS ON CR00025 USING 00002 BLKS R-0002 


0001 : PU.IMDIRC: IM: 23: 4: 100 

0002 : r R, IMDIRC: IM? 23: 4: 100 


LWTAPE T-00004 IS ON CR00022 USING 00002 BLKS R-OOIO 


0001 

LG, 3 

0002 

SV,0 

0003 

OF.WTAPE 

0004 

PU.WTAPE 

0005 

MR.XWTAPE 

0006 

,MR,%R0T8 

0007 

; MR , %ICMPW 

0008 

: MR , XTRMGN 

0009 

i RU.LOADR.99.0G 

0010 

: SP , 1 OG : : 3 

G'ni 

:TR 


LDPLAM T*00004 IS ON CR00022 USINC 00002 BLKS R-0010 

0001 :SV,0 

0002 : OF, DPLAM 

0003 :PU, DPLAM 

0004 :LG,3 

0005 : MR, 2DPLAM 

0006 : MR, XDPLAl 

0007 : RU.LOADR, 99, OG 

0008 : SP, 10G: : 3 

0009 : OF , 1 OG 

0010 : RP, 10G: : 3 

0011 :: 


LPLOTV T=00004 IS ON CR00022 USING 00002 BLKS R=0011 

0001 : SV,0 

0002 : OF , PLOTV 

0003 :PU, PLOTV 

0004 :LG,3 

0005 : MR, %EES3 

0006 : MR, XDRIVR 

0007 : RU ,LOADR, 99, OG 

0008 : SP , 10G: : 3 

0009 : OF, 10G 

0010 : RP, 10G: : 3 

0011 :: 


2 


LFDIGN T-00004 IS ON CROOC22 USING 00002 BLKS R-OOU 


0001 : SV,0 

0002 : OF.FDIGN 

0003 : PU.FDIGN 

0004 : LG,3 

0005 : MR, %FDIGN 

0006 : MR, XFDIGl 

0007 :RU,LCADR,99,1G 

0008 : PU, ICO: : 3 

0009 : SP, IOG: : 3 

00 10 : OF , l 00 

001 1 :: 

0012 


LBLDIM T-00004 IS ON CR00022 USING 00002 BLKS R-0009 


0001 

LG ,2 

0002 

0F,BLDIM 

0003 

PU.BLDIM 

0004 

MR,ZBLDIM 

0005 

MR.MVW. 

0006 

MR , XR0T8 

0007 

MR, %RLINE 

0008 

MR, DCODE . 

0009 

MR.ZDRIVR 

0010 

RU,L0ADR,99,0C 

0011 

SP , IOG: : 3 

0012 

OF , IOG: : 3 

0013 

RP, IOG: : 3 

0014 

• 

• 


LLFTR T-00004 IS ON CR00022 USING 00002 BLKS R-OOll 


0001 

: SV ,0 

0002 

: OF , LFLTR 

0003 

: PU.LFLTR: : 3 

0004 

: LG, 3 

0005 

: MR, XLFLTR 

0006 

: MR, %WFINT 

0007 

: MR, DCODE. 

0008 

: MR, XWLINE 

0009 

: MR, XDRIVR 

0010 

:RU,L0ADR,99,1G 

00 L l 

: SP , IOG: : 3 

0012 

: OF, IOG 

0013 

: RP , l OG : : 3 

0014 

J | 


LHFTR T-00004 IS ON CR00022 USING 00002 BLKS R-0014 

0001 : SV , 0 

0002 :OF,HFLTR 

0003 : PU,HFLTR: : 3 

0004 :LG,3 

0005 : MR , 2HFLTR 

0006 s MR,%WFINT 

0007 :RU,L0ADR,99,1G 

0008 : SP,10G: : 3 

0009 : OF, I0G 

0010 : RP,10G: : 3 

0011 ss 


LSHOW T-00004 IS ON CRC0022 USING 00C02 BLKS R-0011 

0001 : LG , 1 

0002 : MR, X SHOW 

0003 :MR,%WFINT 

0004 :>1R,%DRIVR 

0005 : MR, %WLINE 

0006 : OF, SHOW 

0007 : RU ,LQADR, 99, 1G 

0008 : PU, 10G: : 3 

0009 : SP, 10G: : 3 

0010 : OF, 10G 

0011 :: 


LFIRO T=00004 IS ON CR00022 USING 00002 BLKS R-0010 

0001 : LG, l 

0002 : MR, %FIRO 

0003 : MR, 3JWIND0 

0004 : MR, XBESIO 

0005 : OF,FIRO 

0006 : RU,L0ADR,99,0G 

0007 : PU, 10G: : 3 

0008 : SP, 10G: : 3 

0009 : OF, IOC 

0010 : RP, 10G: : 3 

0011 :: 




A. 


t if Wi fTr n 


L IMAGE T-00004 IS ON CR00022 USING 00002 BLKS R-0009 


0001 

LG, 1 

0002 

OF , IMAGE 

0003 

MR, 2 IMAGE 

0004 

MR.7.SPACE 

0005 

MR.7.ICMPW 

0006 

MR.2R0T8 

0007 

RU,L0ADR,99, 1G 

0008 

PU, 10G: : 3 

0009 

SP.10G: : 3 

0010 

OF , 1 OG 


LRESI2 T=00004 IS ON CR00022 USING 00002 BLKS R-0004 

0001 : LG , 3 

0002 : SV , 0 

0003 : OF , RESIZ 

0004 :PU, RESIZ 

0005 : MR, 2RESIZ 

0006 : MR,2DRIVR 

0007 :MR,%WLINE 

0008 : MR , ZTRMGN 

0009 : MR, ZLBRSZ 

0010 : MR, ZWFINT 

0011 : RU , LOA DR , 99 , OG , , , 2 

0012 : SP , 10G: : 3 

0013 : TR 


LDINTP T=00004 IS ON CR00022 USING 00002 BLKS R-0011 


0001 

: LG , 3 

0002 

: SV,0 

0003 

: OF, DINTP 

0004 

: PU, DINTP 

0005 

: MR, 2DINTP 

0006 

:MR,%DRIVR 

0007 

:MR,%ULINE 

0008 

: MR , ZTRMGN 

0009 

:MR,%LBRSZ 

0010 

: MR, ZWFIHf 

0011 

:RU,LOADR,99,OG 

0012 

: SP , 10G: : 3 

0013 

: TR 
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LBLDWF T-00004 IS ON CR00022 USING 00002 BLKS R-0009 

0001 :LG,0 

0002 :LG,2 

0003 :0F,BLDWF 

0004 sPU.BLDWF 

0005 :MR,%BLDWF 

0006 :MR,ZICMPW 

0007 :RU,LOADR,99,OG,,,2 

0008 : SP, 10G: : 3 

0009 : OF, 10G: : 3 

0010 :RP,10G::3 

0011 s: 


LDSPLY T-00004 IS ON CR00022 USING 00002 BLKS R-0011 


0001 

:LG,1 

0002 

:MR,%DSPLY 

00.03 

:MR,%SCROL 

0004 

:MR,%WLINE 

0005 

:MR,%DRIVR 

0006 

:MR,%RESET 

0007 

: 0F,DS?LY 

0008 

: RU ,LOADR, 99, OG 

0009 

: PU, 10G: : 3 

0010 

: SP, 10G: : 3 

0011 

:OF,10G 


LCURSR T»00004 IS ON CR00022 USING 00002 BLKS R=0012 

0001 :LG,i 

0002 :MR,%CURSR 

0003 :MR,%WLINE 

0004 :MR,%RLINE 

0005 : MR, %DRIVR 

0006 :MR,%MOVEC 

0007 :OF,CURSR 

0008 :RU,L0ADR,99,1G 


0009 : PU, 10G: : 3 

0010 : SP, 10G: : 3 

0011 : OF, 10G 





'4 



LNOISE T-00004 IS ON CR00022 USING 00002 BLKS R-0011 


0001 

LG, 1 

0002 

MR,%NOISE 

0003 

MR.XBLDWF 

0004 

MR.ZWFINT 

0005 

MR.ZICMPW 

0006 

OF, NOISE 

0007 

RU,LOADR,99,lG 

0008 

PU, 10G: : 3 

0009 

SP.10G: :3 

0010 

OF , 10G 

0011 

• 


NASA T-00004 IS ON CR00022 USING 00002 BLKS R-0008 


0001 : SV,4 

0002 : OF, SHOW 

0003 : RP,SHOW 

0004 :OF,BLDWF 

0005 :RP,BLDWF 

0006 : OF , BLDIM 

0007 :RP, BLDIM 

0008 : OF, WTAPE 

0009 : RP , WTA PE 

0010 : OF , DSPLY 

0011 :RP, DSPLY 

0012 : OF.CURSR 

0013 : RP,CURSR 

0014 : OF.FDIGN 

0015 : RP, FDIGN 

0016 : OF , SIABI 

0017 :RP, SIABI 

0018 : OF , DPLAM 

0019 : RP, DPLAM 

0020 :OF,FILTR 

0021 : RP, FILTR 

0022 : OF , LFLTR 

0023 :RP, LFLTR 

0024 :0,-, PLOTV 

0025 : RP, PLOTV 

0026 : OF , HFLTR 

0027 :RP, HFLTR 

0028 : OF , RESIZ 

0029 :RP, RESIZ 

0030 : OF , IMAGE 

0031 :RP, IMAGE 

0032 : OF, DINTP 

0033 :RP, DINTP 

0034 : OF, NOISE 

0035 :RP, NOISE 

0036 : MC,23 

0037 : SV ,0 

0038 : RU.NASAl 

0039 : OF, SHOW 

0040 : OF, BLDWF 

0041 : OF, DSPLY 

0042 : OF.CURSR 

0043 : OF, FDIGN 

0044 : OF , STAB I 

0045 : OF, DPLAM 

0046 :OF, FILTR 

0047 : OF, LFLTR 

0048 : OF, PLOTV 

0049 : OF, HFLTR 

0050 : OF, RESIZ 

0051 : OF, IMAGE 

0052 : OF, BLDIM 

0053 ; OF, DINTP 

0054 : OF , WTAPWTAPE 

0055 


& MASAI T -00004 IS ON CR00022 USING 00008 BLKS R-0054 


0001 

FTN4.L 


0002 


PROGRAM NASAl 


0003 

C 

THIS PROGRAM IS THE FATHER PROGRAM FOR THE IMAGE FILTERING 

0004 

C 

PROGRAMS 


0005 

C 



0006 


DIMENSION IPRAM( 5) , NAME(3) ,NS0N(3, 8) , IMESS(30) 


0007 


DATA NS0N/2HDS , 2HPL , 2HY , 2HFD,2HIG, 2HN ,2HFI,2HLT, 


0008 


*2HR , 2HRE, 2HSI , 2HZ , 2HSH, 2H0W, 2H , 2HIM, 2HAG, 2HE , 


0009 


*2HN0,2HIS,2HE / 


0010 

C 



0011 

C 

SON PROGRAM NAMES (FILES SAME PRESEDED WITH "&") 


0012 

C 

DSPLY - DISPLAY PROGRAM 


0013 

c 

FDIGN - FILTER DESIGN MODULE 


0014 

c 

FILTR - FILTER IMPLEMENTION MODULE 


0015 

c 

RESIZ - IMAGE MODIFICATION MODULE 


0016 

c 

SHOW - DISPLAYS WORK FILE 


0017 

c 

IMAGE - IMAGE DATA MANAGEMENT MODULE 


0018 

c 

NOISE - ADDITIVE GAUSSIAN NOISE 


0019 

c 



0020 


CALL RMPAR(IPRAM) 


0021. 


LU=*IPRAM( l ) 


0022 


LF(LU.LE.O) LU-1 


0023 

c 



0024 

c 

1IPRG IS THE NUMBER OF SONS 


0025 

c 



0026 


NPRC=6 


0027 


ICNT"9 


0028 

c 



0029 

c 

DISPLAY MENU 


0030 

c 



0031 


5 WRITE(LU , 30) 


0032 


30 FORMAT( " SELECT PROCESSING OPTION"/,” 1. IMAGE DISPLAY"/ 

0033 


^FILTER DESIGN"/,” 3. FILTER IMAGE"/," 4. MODIFY 

IMAGE" 

0034 


* SHOW WORK FILE"/," 6. IMAGE DATA MANAGEMENT"/," 

7. NO 

0035 


*0N" / , " 8. TERMINATE PROGRAM") 


0036 


READ(LU,*) IOPT 


0037 


IF(IOPT.EQ.O.OR.IOPT.EQ.l) IOPT - l 


0038 


IF(IOPT.LT.i.OR. IOPT . GT. 8) GO TO 16 


0039 


IF( IOPT .EQ. 8) GO TO 500 


0040 

c 



0041 


IPRAM( 2)"I0PT 


0042 


DO 10 1-1,3 


0043 


10 NAME( I )=»NSON( I , IOPT) 


0044 


WRITE(LU, 15) NAME 


0045 


15 FORMAT ( " MODULE TO BE SCHEDULED IS ",3A2) 


0046 


GO TO 20 


0047 


16 WRITE(LU, 17) 


0048 


17 FORMAT( " INVALID RESPONSE") 


0049 


GO TO 5 


0050 

c 




0051 

0052 

0053 

0054 

0055 

0056 

0057 

0058 

0059 

0060 
0061 
0062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 
0073 

0079 

0080 
0081 
0082 

0083 

0084 

0085 


9 

20 ICNW-LU+200B 

CALL EXEC( 13, ICNW, IPRAM( 3) , IPRAM(4) , IPRAM(5) ) 

CALL E XEC ( 2 3 , NAME , l PRAM ( l ) , I PRAM( 2 ) , l PRAM( 3 ) , I PRAM( 4 ) , I PRAM( 

WRITE ( LU, 40) (IPRAM(I), 1-1,5) 

40 F0RMAT( "PARAMETERS RETURNED FROM MODULE"/ , 5( 1H, 4E1 l . 3 , 2X) ) 

GO TO 5 
500 CONTINUE 

C OF ALL SON PROGRAMS 
C 

DO 510 I-l.NPRG 

CALL FILL(IMESS,2H ,30) 

CALL CODE 

WRITE ( IMESS, 520) (NSON( J , I ) , J-l , 3) 

520 FORMAT ( "OF,", 3A2) 

IRTN-MESSS ( IMESS , ICNT , LU) 

IF(IRTN.LT.O) CALL EXEC(2, LU, IMESS, IRTN) 

510 CONTINUE 
C 

STOP 

END 

C 

C 

SUBROUTINE FILI .IARAY,IA,N) 

C 

C THIS SUBROUTINE FILLS ARRAY I A RAY WHICH HAS N WORDS WITH THE 
C OF IA. 

C 

DIMENSION IARAY(N) 

DO 10 I-1,N 
10 IA RA Y ( I ) *■ IA 
RETURN 

$ END 


0001 

0002 

0003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 
0011 
0012 

0013 

0014 

0015 

0016 
COi 7 
0013 

0019 

0020 
0021 
0022 

0023 

0024 

0025 

0026 
0027 
0023 

0029 

0030 

0031 

0032 

0033 

0034 

0035 

0036 

0037 

0038 

0039 

0040 

0041 

0042 

0043 

0044 

0045 

0046 

0047 

0048 

0049 

0050 

0051 

0052 

0053 

0054 

0055 

0056 

0057 

0058 

0059 


FTN4 

PROGRAM DSPLY 
C 

C THIS PROGRAM DISPLAYS AN IMAGE ON THE CMR-27. IMAGE FILE MUST 
C BE IN FORMAT DESCRIBED BY IMAGE DISPLAY SUBSYSTEM. 

C 

INTEGER SLU1 1 , STRTL , STRTP , SCROL 
C 

DIMENSION NAME(6) , IDCB( 144) , IBLK( 513) , ISET( 10) ,LU(5) , JNAME(3 
INTEGER TEXT 1 ( 38 ) , TEXT2 ( 38 ) , TEXT 3(38) 

C 

EQUIVALENCE ( IBLK( 7 ) , IBLK7 ) , (IBLK(8) , IBLK8) , ( IBLK( 12) , 1BKi2) 

1 ( IBLK( 13} , JNAME) , (TEXT! , IBLK( 129) ) , (IBLK( 169) ,TEXT2 ) , 

2 ( I8LK( 209) ,TEXT3) 

EQUIVALENCE ( ISET( 5 ) , ISET5) , ( ISET(6) , ISET6) , ( ISET( 7 ) , ISET7 ) , 
1 ( ISET(8) ,ISET8) , (ISET(9) ,ISET9) 

C 

DATA ISET/100377B .10377B .24001B .30000B , 5*-l , 260C2B/ 

DATA SLU1 1/3401 IB/ 

DATA LLA0,LEA0,LEC0,LLB1 ,LLBX,LEB1 ,LEBX/64000B ,44000B , 54000B 
l 70001B, 7l777B,50001B, 51777B/ 

C 

C 

C GET INPUT PARAMETERS 
C 

CALL RMPAR(LU) 

IF (LU .LE. 0) LU - l 
C 

C OPEN IMAGE DIRECTORY FILE 
C 

100 CALL OPEN(IDCB, IERR, 6HIMDIRC) 

IF (IERR .LT. 0) GO TO 991 
C 


C GET IMAGE FILE NAME 
C 


C 


20 

21 

22 

23 

24 
26 

25 
27 
105 

2 


CALL RESET(LU) 
WRITE(LU, 20) 


E 

dB 

dB 


D I S P L 


WRITE(LU, 21 ) 

WRITE(LU, 22) 

WRITE(LU, 23) 

WRITE(LU, 24) 

WRI1'E(LU , 26) 

WRITE(LU, 26) 

WRITE(LU, 26) 

FORMAT(20X, "I MAG 
FORMAT ("IMAGE NAME: 

FORMAT ( "f? LINES: 
l" If PIXELS/LINE: dB 
FORMAT ("MIN PIXEL: 
l "MAX PIXEL: dB 

FORMAT( "TEXT 
FORMAT( "dB" , 38" 

FORMAT ( "_” ) 

FORMAT (” ") 

WRITE(LU, 25) 

READ(LU, 2 ) NAME 
FORMAT(6A2) 

IF (NAME .EQ. 2H/E) GO TO 9000 


A Y 
d@"/ ) 


d@” , 20X, 
d<?"/) 

dt, d@" , 18X, 

d<?"/) 

,”d@") 


S Y S T E M"//) 


FIND IMAGE FILE 


0060 

0061 

0062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 
0073 

0079 

0080 
0081 
0082 

0083 

0084 

0085 

0086 

0087 

0088 

0089 

0090 

0091 

0092 

0093 

0094 

0095 

0096 

0097 

0098 

0099 

0100 
0101 
0102 

0103 

0104 

0105 

0106 

0107 

0108 

0109 

0110 


C 
C 
C 

CALL RWNDF(IDCB) 

110 CALL READF(IDCB, IERR, 1BLK, 256,LEN) 

IF (IERR .LT. 0) GO TO 991 
IF (LEN .EQ. -1) GO TO 800 
C 

DO 120 1-1,6 

IF (IBLK(I) .NE. NAME ( I ) ) GO TO 110 
120 CONTINUE 
C 

C IMAGE FOUND— CHECK IF ON DISC 
C 

IF (IBK12 .EQ. 1) GO TO 130 
C 

C IMAGE NOT ON DISC 
C 

WRITE(LU, 12) 

12 FORMAT (" 

GO TO 105 
C 

C IMAGE IS ON DISC 
C 

130 CALL CLOSE(IDCB) 

RMIN - IBLK(9) 

RMAX - IBLK(IO) 

WRITE(LU, 23) (IBLK(I) ,1-7 , 10) 

28 FORMAT (" 

CALL EXEC(2,LU,TEXT1 , 37) 

CALL EXEC(2,LU,TEXT2, 37) 

CALL EXEC(2 ,LU,TEXT3, 37) 

WRITE(LU, 27) 

CALL OPEN(IDCB,IERR, JNAME) 

IF (IERR .LT. 0) GO TO 991 
C 

C EXTRACT DISPLAY INFORMATION 
C 

NUML - IBLK7 
NUMP - IBLK8 

STRTL - (256-MIN0(256,NUML))/2 
STRTP - (512-MIN0( 512, NUMP))/2 
C 

500 ISET5 - IOR(LLAO, IAND( STRTL, 1777B) ) 
ISET6 - IOR(LEAO,IAND(STRTP, 1777B)) 
ISET7 - LLB1 
ISET8 - LEBl 

ISET9 - IOR(LECO, IAND( STRTP , 1777B) ) 
C 

CALL DRIVR(2 , ISET, 10) 

C 


0111 


IERR - 0 

0112 


DO 600 I-1,MIN0(NUML,256) 

0113 


IF (IERR .LT. 0) GO TO 991 

0114 


CALL READF( IDCB, IERR, IBLK, 512, NUM) 

0115 


IF (NUM .LT. 0) GO TO 600 

0116 

C 


0117 


DO 595 J-l.NUM 

0118 


IBLK(J) - (255. /(RMAX-RMIN) )*(FLQAT( IBLK( J) )-RMlN) 

0119 


IF (IBLK(J) .LT. 0) IBLK(J) - 0 

0120 


IF (IBLK(J) .CT. 377B) IBLK(J) - 377B 

0121 

595 

CONTINUE 

0122 

C 


0123 


IBLK(NUM+1) - SLUll 

0124 


CALL DRIVR(40002B,IBLK,NUM+l) 

0125 

600 

CONTINUE 

0126 


IFRST - 0 

0127 


I LAST - 255 

0128 

C 


0129 

C 


0130 

C OUTPUT SOFT KEY FUNCTIONS 

0131 



0132 


WRITE(LU, 29) 

0133 

29 

FORMAT( / ''FUNCTION KEYS:"/) 

013*4 


WRITE( LU, 30) 

0135 


WRITE(LU, 30) 

0136 

30 

FORMAT(4("dB d(? ")/) 

0137 

605 

WRITE(LU, 31) 

0133 

31 

FORMAT (” 

0139 


WRITE(LU, 32) 

0140 

32 

FORMAT (” << SCROLL SCROLL » CURSOR 

0141 


124X, ” NEW IMAGE EXIT ") 

0142 

610 

CALL EXEC( 1 , LU, INPT, 1) 

0143 


INPT - INPT-7023 

0144 


IF (INPT .LT. 1 .OR. INPT .GT. 8) GO TO 610 

0145 

C 


0146 

C 

BRANCH TO APPROPRIATE SECTION 

0147 

C 


0148 

C 


0149 


CO TO (1000, 2000, 3000, 4000, 5000, 6000, 100, 9000), INPT 

0150 

C 


0151 

C 


0152 

C 


0153 

C SCROLL IMAGE BACK 

0154 

c 


0155 

1000 

IERR =* S CROL( IDCB, -9, NUML, IFRST, ILAST,RMAX,RMIN) 

0156 


IF (IERR .LT. 0) GO TO 991 

0157 


GO TO 610 


13 


0158 C 

0159 C SCROLL FORWARD 


0160 

C 


0161 

2000 

IERR - SCR0L( IDCB, 1 7 ,NUML, IFRST, ILAST,RMAX,RM1N) 

0162 


IF (IERR .LT. 0) GO TO 991 

0163 


GO TO 610 

0164 

3000 

CONTINUE 

0165 

C 


0166 

C POSITION CURSOR 

0167 

C 


0168 

4000 

CALL EXEC( 23 , 6HCURSR ,LU) 

0169 


CO TO 605 

0170 

5000 

CONTINUE 

0171 

6000 

CONTINUE 

0172 


GO TO 610 

0173 

c 


0174 

C TERMINATE 

0175 

C 


0176 

9000 

CALL CLOSE(IDCB) 

0177 


CALL RESET(LU) 

0178 


WRITE(LU, 33) 

0179 

33 

FORMAT( "END PROGRAM") 

0180 


CALL EXEC(6) 

0181 

C 


0182 

C FILE NOT FOUND 

0183 

C 


0184 

800 

WRj.TE(LU ,3) 

0185 

3 

FORMAT(" 

0186 


CO TO 105 

0187 

C 


0188 

991 

CALL RESET(LU) 

0189 


WRITE(LU, 9) IERR 

0190 

9 

FORMAT( "FILE ERROR", 16) 

0191 


CALL CLOSE(IDCB) 

0192 


END 


0193 $ 
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&CUR3R T-00004 IS ON CR00022 USING 00005 BLKS R-0037 

0001 FTN4 

0002 PROGRAM CURSR 

0003 C 

0004 DIMENSION LU( 5) , IBUF(2352) , IZERO( 2> 

0005 C 

0006 INTEGER EA.LA 

0007 C 

0008 OATA IZERO/44000B, 640008/ 

0009 C 

0010 C 

0011 CALL RMPAR(LU) 

0012 C 

0013 C 

0014 C SAVE IMAGE LINES 

0015 C 

0016 C 

0017 DO 50 1-0,20 

0018 CALL RLINE(I ,0, l 1 l ,IBUF( 112*1+1 ) ) 

0019 50 CONTINUE 

0020 WRITE(LU.l) 

0021 l FORMAT! ” 

0022 WRITE(LU, 2) 

0023 2 FORMAT! “ LEFT UP RIGHT 

0024 H2X,” DOWN ”,12X, M RETURN ") 

0025 CALL MOVEC!0,255) 

0026 EA - 0 

0027 LA - 255 

0028 100 CALL EXEC! l,LU,INPT, 1) 

0029 INPT - INPT-7023 

0030 IF ! INPT .LT. I .OR. INPT .GT. 8) GO TO 100 

0031 C 

0032 C 

, 0033 C BRANCH TO APPROPRIATE SECTION 

0034 C 

0035 C 

0036 GO TO (400, 200, 500, 100, 100, 300, 100, 600), INPT 

i 0037 C 

i 0038 C MOVE CURSOR UP 

0039 C 

0040 200 LA - MOD(LA+ll,256) 

0041 CALL MOVEC(EA.LA) 

0042 GO TO 100 

; 0043 c 

f 0044 c MOVE CURSOR DOWN 

i 0045 C 

0046 300 LA - MOD(LA+249, 256) 

0047 CALL MOVEC(EA.LA) 

0048 GO TO 100 

' 0049 C 

0050 C MOVE CURSOR LEFT 

0051 C 

0052 400 EA - MOD(EA+499, 512) 

0053 CALL MOVEC(EA.LA) 

0054 GO TO 100 

0055 C 


0056 

C MOVE CURSOR RIGHT 

0057 

C 


0058 

500 

EA » MOD(EA+I7,5I2) 

0059 


CALL MOVEC(EA,LA) 

0060 


GO TO 100 

0061 

C 


0062 

C RETURN TO PREVIOUS SCREEN 

0063 

C 


0064 

600 

DO 610 1-0,20 

0065 


CALL WLINEC I, O.IU.IBUFC 112*1+1)) 

0066 

610 

CONTINUE 

0067 

C 


0068 


CALL DRIVR( 2 , IZERO , 2 ) 

0069 

C 


0070 


END 

0071 

$ 



&ICMPW T -00004 IS ON CR00022 USING 00002 BLKS R-0011 


0001 

FTN4 


0002 


FUNCTION ICMPW ( IBUF 1 , IBUF 2 , ILEN ) 

0003 


DIMENSION IBUFl(i) ,IBUF2(1) 

0004 


DO 100 I-l.ILEN 

0005 


IF (IBUFl(I) NE. IBUF2(I ) ) GO TO 200 

0006 

100 

CONTINUE 

0007 


ICMPW - 0 

0008 


RETURN 

0009 

200 

ICMPW - I 

0010 


END 

0011 

$ 



& RESET T-00004 IS ON CR00022 USING 00002 BLKS R-0017 


0001 

FTN4 

0002 


SUBROUTINE RESET(LU) 

0003 

C 


0004 

C 


0005 


WRITE(LU, 1 ) 

0006 

1 

FORMAT (" 

0007 

C 


0008 

C 

WAIT 200 MSEC 

0009 

C 


0010 


CALL EXEC(12, 0,1, 0,-20) 

0011 

C 


0012 

C 

CLEAR DISPLAY 

0013 

c 


0014 


WRITE(LU, 2) 

0015 

2 

FORMAT( "" ) 

0016 


END 

0017 

$ 
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&RLINE T-00004 IS ON CR00022 USING 00005 BLKS R-0039 

0001 FTN4 ,L 

0002 SUBROUTINE RLINE(LINE, IPIX, JPIX, IDATA) 

0003 C 

0004 C THIS SUBROUTINE READS A LINE FROM GMR-27. 

0005 C 

0006 C WHERE 

0007 C LINE - LINE # TO READ 

0008 C IPIX - STARTING PIXEL 

0009 C JPIX - ENDING PIXEL 

0010 C 

00 11 C IDATA - BUFFER IN WHICH DATA IS RETURNED (1 PIXEL/WO^D 

0012 C 

0013 C 

0014 DIMENSION IDATA(512) ,INIT(5) 

0015 C 

0016 EQUIVALENCE (LLA ,INIT(2) ) , (LEA , INIT( 3) ) , (LEB,INIT(4) ) 

0017 C 

0018 DATA INIT/ 10037 7B , 64000B , 44000B , 50000B , 26002B/ 

0019 C 

0020 C COMPUTE DIRECTION 

0021 C 

0022 IDIRC - 1 

0023 IF IPIX .GT. JPIX) IDIRC - -1 

0024 C 

0025 C SET UP FOR READ BACK 

0026 C 

0027 LLA - 64000B + IAND(LIN£, 377B) 

0028 LEA - 440008 + IAND( IPIX, 777B) 

0029 LEB - 50000B + IDIRC + 512 

0030 CALL DRIVR(2,INIT, 5) 

0031 C 

0032 C READ BACK LINE 

0033 C 

0034 NUM - IDIRC*( JPIX- IPIX )+l 

0035 CALL DRIVR( l , IDATA , NUM) 

0036 C 

0037 

0038 

0039 $ 


RETURN 

END 


AMOVE C T-00004 IS ON CR00022 USING 00004 BLKS R-0031 
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0001 FTN4.L 

0002 SUBROUTINE MOVEC(IX.IY) 

0003 C 

0004 C THIS SUBROUTINE MOVES THE CURSOR ON THE GMR-27. ITS POSITION I 

0005 C INDICATED IN THE LOWER LEFT HAND CORNER OF THE SCREEN. 

0006 C 

0007 C IX - X-COORDINATE 

0008 C IY - Y-COORDINATE 

0009 C 

0010 C 

0011 INTEGER WACO 

0012 C 

0013 DIMENSION ICR(7) , IPOO( 5) , IPXY( 3) 

0014 C 

0015 EQUIVALENCE ( ICR , ICRI ) , ( ICR( 2 ) , ICR2 ) , ( ICR( 3 ) , ICR3 ) , ( ICR( 3) , I 

0016 1 (ICR(6) , ICR6) , (ICR(7) , ICR7) , ( IPXY, IPXY1 ) ,(IPXY(2) ,IPXY2) 

0017 C 

0018 DATA IP00/44000B , 64000B , 240I5B , 500.^8 , 2o002B/ 

0019 DATA ICR/0,0, 0.22054B, 0,0,0/ 

0020 DATA IPXY/0,0, 24001B/ 

0021 DATA WACO ,LEA0,LL\0/22000B ,44000B , 64000B/ 

0022 C 

0023 C 

0024 C 

0025 C WRITE POSITION ON SCREEN 

0026 C 

0027 CALL DRIVR( 2 , IPOO ,5) 

0028 C 

0029 IDl =» IY/ 100 

0030 ICRI - WACO + IDl +60B 

0031 ID2 - ( IY-ID1*100)/10 

0032 ICR2 - WACO + ID2 +60B 

0033 ID3 = (IY-IDl* 100-102*10) 

0034 ICR3 - WACO + ID3 + 60B 

0035 IDl - IX/100 

0036 ICR5 - WACO +101 + 60B 

0037 ID2 - (IX-ID1*100)/10 

0038 ICR6 - WACO + ID2 + 60B 

0039 ID3 » IX-IDl* 100-102*10 

0040 ICR7 - WACO + 103 + 60B 

0041 C 

0042 CALL DRIVR(2, ICR, 7 ) 

0043 C 

0044 C POSITION CURSOR 

0045 C 

0046 IPXY1 - IOR(LEA0 , IAND( IX , 777B) ) 

0047 IPXY 2 - IOR(LLAO,L\ND(IY,377B)) 

0048 CALL DRIVR(2,IPXY, 3) 

0049 RETURN 

0050 EFD 

0051 $ 
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& IMAGE T-00004 IS ON CR00022 USING 00015 BLKS R-0161 


0001 

FTN4,Q,C,T 

0002 


PROGRAM IMAGE 

0003 

C 


0004 

c 


0005 

c 

THIS PROGRAM IS THE IMAGE FILE MANAGER FOR THE IMAGE DISPLAY 

0006 

c 

SUBSYSTEM. 

0007 

c 


0008 

c 


0009 


DIMENSION LU(5),IDCBl(272),IDCB2(528),lDCB3(144),JNAME(3) 

0010 


1 IFNAM( 3) ,NAME(6) , IDATA(512) ,KNAME(6) 

0011 

c 


0012 


INTEGER ENTRY( 256) , ISIZE( 2) , T «iXTl (19) 

0013 

c 


0014 


EQUIVALENCE (ENTRY(7) , NLINE) , (ENTRY(8) .NPIXL) , (ENTRY(12) ,1 

0015 


1 (ENTRY( 13) , JNAME) , (ENTRY(16) , IFNAM) , (ENTRY( 19) ,IFNUM) 

0016 


2, (ENTRY, KNAME) 

0017 


2 , (TEXT1 ,ENTRY( 129) ) 

0018 


EQUIVALENCE (ISIZE(2) ,ISIZ2) 

0019 

c 


0020 

c 


0021 

c 

GET INPUT PARAMETERS 

0022 

c 


0023 


CALL RMPAR(LU) 

0024 


IF (LU .LE. 0) LU - 1 

0025 

c 


0026 

c 

OUTPUT HEADING 

0027 

c 


0023 

900 WRITE(LU.l) 

0029 

1 

FORMAT ( / / " IMAGE FILE MANAGE R" // ) 

0030 

c 


0031 

c 

GET COMMAND INPUT 

0032 

c 


0033 

1000 WRITE(LU, 2) 

0034 

2 

FORMAT ("> ’•) 

0035 


READ(LU, 3) ICMD 

0036 

3 

F0RMAT(A2) 

0037 

C 


0038 

C 

EXECUTE COMMAND 

0039 

G 


00<*0 


IF (ICMD .NE. 2H? ? ) GO TO 1010 

0041 

C 


0042 

C 

COMMAND IS HELP 

0043 

C 


0044 


WRITE (LU, 4) 

0045 

4 

F0RMAT( /" COMMANDS ARE:"/, 

0046 


1” BU-BUILD IMAGE FILE"/, 

0047 


2" DI-DISPL\Y IMAGE ON GMR-27"/, 

0048 


3" SA-SAVE IMAGE TO TAPE"/ 

0049 


4" RE-RESTORE IMAGE TO DISC"/, 

0050 


4" DL-DIRECTORY LIST"/, 

0051 


4" PU-PURGE IMAGE"/, 

0052 


4" WT-WRITE NASA TAPE"/, 

0053 


5" 77-HELP"/, 

0054 


6" EX-EXIT"//) 

0055 


GO TO 1000 


0056 

0057 

0058 

0059 

0060 
0061 
0062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

0078 

0079 

0080 
0081 
0082 

0083 

0084 

0085 

0086 

0087 

0088 

0089 

0090 

0091 

0092 

0093 

0094 

0095 

0096 

0097 

0098 

0099 

0100 
0101 
0102 

0103 

0104 

0105 

0106 

0107 

0108 

0109 

0110 


C 

1010 IF ( ICMD .NE. 2HBU) GO TO 1030 
C 

C BUILD IMAGE COMMAND 
C 

CALL EXEC( 23+lOOOOOB ,6HBLDIM ,LU) 

GO TO 1020 

5 GO TO 900 
C 

C PROGRAM NOT RP'ED 
C 

1020 WRITE(LU,6) 

6 FORMAT (” BLDIM NOT RP'ED!") 

GO TO 1000 

C 

1030 IF (ICMD .NE. 2HDI) GO TO 1045 

C 

C DISPLAY IMAGE COMMAND 
C 

CALL EXEC( 23+lOOOOOB , 6HDSPLY ,LU) 

GO TO 1040 

7 GO TO 900 
C 

C DSPLY NO RP'ED 
C 

1040 WRITE(LU, 8) 

3 FORMAT (" DSPLY NOT RP'ED!") 

GO TO 1000 
C 

1045 IF (ICMD .NE. 2HWT) GO TO 1050 
C 

C WRITE NASA TAPE 
C 

CALL EXEC( 23 , 6HWTAPE ,LU) 

GO TO 1000 
C 
C 

1050 IF (ICMD .NE. 2HSA .AND. ICMD .NE. 2HRE .AND. 

1 ICMD .NE. 2HPU) GO TO 1200 
C 

C SAVE/RESTORE IMAGE TO/FROM TAPE AND PURGE IMAGE 
C 

C OPEN DIRECTORY FILE 
C 

CALL 0PEN( IDCBI , IERR , 6HIMDIRC, 2 , 2HIM ,23,272) 
IF (IERR .LT. 0) GO TO 9999 
C 

C GET IMAGE NAME 
C 

WRITE(LU, 9) 

9 FORMAT ( ” ENTER IMAGE NAME (12 CHARACTERS )?_”) 
READ(LU.IO) NAME 

10 FORMAT(6A2) 

C 

C FIND IMAGE 


c 

1060 


CALL READF( IDCBl , IERR, ENTRY , 256 , LEN) 
IF (LEN .NE. -1) GO TO 1070 


0111 

0112 

0113 

0114 

0115 

0116 
0117 
0113 

0119 

0120 
0121 
0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 

0132 

0133 

0134 

0135 

0136 

0137 

0138 

0139 

0140 

0141 

0142 

0143 

0144 

0145 

0146 

0147 

0148 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158 

0159 

0160 
0161 
0162 

0163 

0164 

0165 

0166 

0167 

0168 


C 

C EOF REACHED 
C 

WRITE(LU.ll) 

11 FORMAT (" IMAGE NOT FOUND!") 

CALL CLOSE( IDCBl) 

GO TO 1000 
C 

1070 IF (IERR .LT. 0) GO TO 9999 
C 

C COMPARE NAME OF IMAGE 
C 

IF (ICMPW( ENTRY, NAME, 6) .NE. C) GO TO 1060 
C 

C IMAGE FOUND 
C 

IF (ICMD .EQ. 2HRE) GO TO 1120 
IF (ICMD .EQ. 2HPU) GO TO 1300 
C 

C TASK IS TO SAVE IMAGE 
C 

IF (LOC .EQ. 1) GO TO 1090 
C 

C IMACE ALREADY ON TAPE 
C 

WRITE(LU, 12) 

12 FORMAT ( " IMAGE NOT ON DISC!") 

GO TO 1000 

C 

C IMAGE ON DISC 
C 

1090 CALL 0PEN(IDCB2, IERR, JNAME, 0,0, 0,528) 

IF (IERR -LT. 0) GO TO 9999 
C 

C GET TYPE 0 FILE 
C 

C WRITE(LU, 13) 

C13 FORMAT ( " TYPE MT LU 000 9 ?_") 

C READ(LU, 14) IFNAM 

C14 FORMAT(3A2) 

IFNAM-2HLU 
IFNAM( 2) =*21100 
IFNAM( 3) =21108 
WRITE( LU, 131 ) 

131 FORMAT(" SELECT OPTION"/" 1. 8-BIT PACKED"/" 
READ(LU, *) IPACK 
CALL 0PEN(IDCB3, IERR, IFNAM) 

IF (IERR .LT. 0) GO TO 9999 
CALL RWNDF(IDCB3,IERR) 

IF (IERR .LT. 0) GO TO 9999 
WRITE(LU, 15) 

15 FORMAT (" FILE //?_”) 

READ(LU,*) IFNUM 

CALL SPACE( IDCB3 , IERR, IFNUM- l ) 

IF (IERR .LT. 0) GO TO 9999 


2. UNPACKED 


0169 

0170 

0171 

0172 

0173 

0174 

0175 

0176 

0177 

0178 

0179 

0180 
0181 
0182 

0183 

0184 

0185 

0186 

0187 

0188 

0189 

0190 

0191 

0192 

0193 

0194 

0195 

0196 

0197 

0198 

0199 


C 

C WRITE HFADER ON TAPE 
C 

CALL WRITF (IDCB3, IERR, ENTRY, ll) 

IF (IERR .LT. 0) GO TO 9999 
C 

C NOW TRANSFER DATA 
C 

DO 1100 I - l.NLINE 

CALL READF(IDCB2,IERR,IUTA,512) 

IF (IERR .LT. 0) GO TO 9999 
C 

IF ( I PACK .NE. 1) GO TO ilOi 
C 

C PACK DATA 
C 

DO 1102 J »1,NPIXL,2 
K - 0. 5*(J+1) 

IVAR“IDATA ( J+l ) 

CALL R0T8(IVAR,KVAR) 

1102 IDATA(K)-IOR(IDATA(J),KVAR) 

1101 CALL WRITF ( IDCB3 , IERR, IDATA , NPIXL ) 
IF (IERR .LT. 0) GO TO 9999 
1100 CONTINUE 
C 

C WRITE EOF 
C 

CALL WRITF(IDCB3, IERR, 0,-1) 

IF (IERR .LT. 0) GO TO 9999 
C 

C PURGE DISC FILE 


0200 C 

0201 CALL PURGE(IDCB2 , IERR, JNAME , 2HIM) 

0202 IF (IERR .LT. 0) GO TO 9999 

0203 C 

0204 C UPDATE ENTRY 

0205 C 

020C LOC - 2 

0207 C 

0208 CALL POSNT ( IDCB1 , IERR, -1 ) 

0209 IF (IERR .LT. 0) GO TO 9999 

0210 CALL WRITF (IDCB1, IERR, ENTRY, 256) 

0211 IF (IERR .LT. 0) GO TO 9999 

0212 C 

0213 CALL CLOSE(IDCBl) 

0214 CALL RWNDF(IDCB3) 

0215 CALL CLOSE( IDCB3) 

0216 GO TO 1000 

0217 C 

0218 C RESTORE IMAGE FROM TAPE 

0219 C 

0220 1120 IF (LOC .EQ. 2) GO TO 1130 

0221 C 

0222 C IMAGE ON DISC 

0223 C 

0224 WRITE(LU, 16) 

0225 16 FORMAT (" IMAGE ALREADY ON DISC!") 

0226 CALL CLOSE(IDCBl) 

0227 GO TO 1000 
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0223 

0229 

0230 

0231 

0232 

0233 

0234 

0235 

0236 

0237 
0233 

0239 

0240 

0241 

0242 

0243 

0244 

0245 

0246 

0247 

0248 

0249 

0250 

0251 

0252 

0253 

0254 

0255 

0256 

0257 

0258 


C 

C CREATE DISC FILE 
C 

1130 ISIZE - (FL0AT(NLINE)*FLQAT(NPIXL)+127 • ) / 1 28 - 
ISI7.2 - NPIXL 
C 

CALL CREAT( IDCB2 , IERR, JNAME , ISIZE , 2 , 2HIM , 23 , 528) 

IF (IERR .GE. 0) GO TO 1135 
C 

C CAN'T CREATE DISC FILE 
C 

WRITE(LU,19) 

19 FORMAT( " CAN'T CREATE DISC FILE!!’) 

CALL CLOSE(IDCBl) 

GO TO 1000 
C 

C OPEN TYPE 0 FILE 
C 

1135 CALL OPEN( IDCB3 , IERR, IFNAM) 

C 

C GET LU OF TYPE 0 FILE 
C 

CALL LOCF( IDCB3 , IERR, IREC , IRB , IOFF , JSEC , MTLU) 

IF (IERR .LT. 0) GO TO 9999 
C 

C TELL USER TO MOUNT TAPE 
C 

WRITE(LU, 17) MTLU 

17 FORMAT(" MOUNT TAPE ON LU ■•,12" ENTER RETURN WHEN READY") 
CALL EXEC( l ,LU,IREC, 1 ) 

C 


0259 

0260 
0261 
0262 

0263 

0264 

0265 

0266 

0267 

0268 

0269 

0270 

0271 

0272 

0273 

0274 

0275 

0276 

0277 

0278 

0279 

0280 
0281 
0282 

0283 

0284 


C REWIND TAPE 
C 

CALL RWNDF(IDCB3,IERR) 

IF (IERR .LT. 0) GO TO 9999 
C 

C SPACE FORWARD TO FILE 
C 

CALL S PACE ( IDCB3 , IERR, IFNUM-1) 

C 

C READ HEADER 
C 

CALL READF(IDCB3 ,IERR, IDATA.H) 

IF (IERR .LT. 0) GO TO 9999 
IF(ICMPW( IDA TA, ENTRY, ll) .NE. 0) GO TO 1160 
C 

C HEADK.?. COMPARES 
C 

C TRANSFER DATA 
C 

DO 1140 I-1.NL1NE 

CALL READF(IDCB3, IERR, IDATA, NPIXL) 

IF (IERR .LT. 0) GO TO 9999 
CALL WRITF( IDCB2 , IERR, IDATA , NPIXL) 

IF (IERR .LT. 0) GO TO 9999 
1140 CONTINUE 
C 


23 


0285 



CALL RWNDF( IDCB3) 

0286 



CALL CLOSE( IDCB3) 

0287 



CALL CL0SE(IDCB2) 

0288 

C 



0289 

C 

UPDATE DIRECTORY ENTRY 

0290 

C 



0291 



LOC - 1 

0292 

C 



0293 



CALL P0SNT(IDCB1,IERR,-1) 

0294 



IF (IERR .LT. 0) GO TO 9999 

0295 



CALL WRITF(IDCB1, IERR, ENTRY, 256) 

0296 



IF (IERR .LT. 0) GO TO 9999 

0297 



CALL CLOSE( IDCBl , IERR) 

0298 



IF (IERR .LT. 0) GO TO 9999 

0299 

C 



0300 



GO TO 1000 

0301 

C 



0302 

C 

LABEL DOES NO MATCH 

0303 

C 



0304 

1160 

WRITE(LU, 18) 

0305 

18 


FORMAT (" WRONG FILE!!") 

0306 



CALL RWNDF( IDCB3) 

0307 



CALL CLOSE( IDCB3) 

0308 



CALL CLOSE(IDCBl) 

0309 



GO TO 1000 

0310 

C 



0311 

C 



0312 

1200 

IF (ICMD ,NE. 2HDL) GO TO 1230 

0313 

C 



0314 

C 

DIRECTORY LIST 

0315 

C 



0316 

C 

OPEN DIRECTORY FILE 

0317 

C 



0318 



CALL OPEN(IDCBl ,IERR,6H1MDIRC) 

0319 



IF (IERR .LT. 0) GO TO 9999 

0320 

C 



0321 

C 

OUTPUT HEADING 

0322 

C 



0323 



WRITE(LU, 30) 

0324 

30 


FORMAT (//"IMAGE NAME //LINES //PIXELS 

0325 

C 



0326 

C 

OUTPUT INFO 

0327 

C 



0328 

1210 

CALL READF(IDCB1, IERR, ENTRY, 256, LEN) 

0329 



IF (LEN .NE. -1) GO TO 1220 

0330 

C 



0331 

C EOF 

REACHED 

0332 

c 



0333 



CALL CL0SE( IDCBl) 

0334 



GO TO 1000 

0335 

c 



0336 

1220 

IF (IERR .LT. 0) GO TO 9999 

0337 

C 



0338 



IF (ENTRY .EQ. -1) GO TO 1210 

0339 



ICHR =■ 2HD 

0340 



IF (LOC .NE. 1) ICHR - 2HT 

0341 



WRITE(LU , 31)KNAME,NLINE,NPIXL,ICHR,TEXT1 

0342 

31 


FORMAT(6A2,2X,I4,4X,I4,3X,A5,2X,’9A2) 

0343 



GO TO 1210 


TEXT"/) 


0344 

C 


0345 

1230 

IF (ICMD .EQ. 2 HEX) GO TO 1240 

0346 

C 


0347 

C ILLEGAL COMMAND 

0348 

C 


0349 


WRITE(LU, 22) 

0350 

22 

FORMAT( "ILLEGAL COMMAND!") 

0351 


GO TO 1000 

0352 

C 


0353 

1240 

WRITE(LU, 23) 

0354 

23 

FORMAT( "END PROGRAM" ) 

0355 


CALL EXEC( 6) 

0356 

C 


0357 

C PURGE FILE 

0353 

C 


0359 

1300 

CALL POSNT( IDCBl , IERR, -1 ) 

0360 


IF (IERR .LT. 0) GO TO 9999 

0361 


ENTRY - -1 

036? 


CALL WRITE (IDCBl , IERR, ENTRY, 256) 

0363 


IF (IERR .LT. 0) GO TO 9999 

0364 

C 


0365 

C PURGE DATA FILE 

0366 

C 


0367 


CALL PURGE ( IDCB2 , IERR, JNAME , 2HIM) 

0368 


CALL CLOSE( IDCBl) 

0369 


GO TO 1000 

0370 

C 


0371 

C 


0372 

C ERROR 

0373 

C 


0374 

C 


0375 

9999 

WRITE(LU, 20) IERR 

0376 

20 

FORMATC FILE ERROR ”,I6) 

0377 


CALL CLOSE(IDCBl) 

0373 


GO TO 1000 

0379 


END 

0380 

$ 



ASPACS T-00004 IS ON CR00022 USING 00004 BUS R-OG29 


25 


0001 

FTN4 


0002 


SUBROUTINE SPACE( IDCB , IERR, NUM) 

0003 

C 


0004 

C 

THIS SUBROUTINE IS USED TO SPACE FORWARD OR BACKWARD THE 

000 j 

C 

NUMBER OF FILES SPECIFIED. 

0006 

C 


0007 


DIMENSION IDCB( 144) 

GoC8 

C 


0009 


DATA IFRWD, IBACK/1300B, 1400B/ 

0010 

C 

• 

0011 

C 


0012 

C 


0013 


IERR - 0 

0014 


IF (NUM .EQ. 0) RETURN 

0015 

C 


0016 


IDIR =■ IFRWD 

0017 


IF (NUM .GT. 0) GO TO 100 

0013 


IDIR - IBACK 

0019 


NUM - -NUM 

0020 

c 


0021 

c 


0022 

100 

DO 110 I-l.NUM 

0023 


CALL FC0NT(IDCB t I5RR,IDIR) 

0024 


IF (IERR .LT. 0) RETURN 

0025 

110 

CONTINUE 

0026 

c 


C927 


RETURN 

0023 


END 

0029 

$ 





&RESIZ T-00004 IS ON CROC 022 USING 00060 BLKS R-0541 


0001 

0002 

0003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 
OOU 
0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 
0021 
0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

0030 

0031 

0032 

0033 

0034 

0035 

0036 

0037 

0038 

0039 

0040 

0041 

0042 

0043 

0044 

0045 

0046 

0047 

0048 

0049 

0050 

0051 

0052 


FTN4,Q,T,C 

PROGRAM RESIZ 

C WRITTEN BY W. E. ALEXANDER 
C 

C PROGRAM FORMS A PART OF THE SPATIAL DOMAIN FILTERING PACKAGE 
C 

C PROGRAM ALLOWS THE USER TO INTERPOLATE AND SCALE AN IMAGE AN 

C CHANGE ITS DATA TYPE. THUS A FLOATING POINT IMAGE CAN BE MAD 

C INTO AN EIGHT BIT IMAGE. 

C 

C 

C 

DIMENSION F(512),G(512), IOP( 512) , IPRAM( 5) ,NSON( 3,2) 

DIMENSION A(3,2,2),B(3,2,2) ,NAME(3) , INM( 3) 

DIMENSION JMES(40) ,DIRC( 515) , IRTM( 5) 

INTEGER WFINT,READL,RITEL 
EQU I VALENCE (G( 1),I0P(1)) 

EQUIVALENCE (F( 1 ) ,G( 1 ) ) 

EQUIVALENCE (DIRC(4) ,F( 1) ) , (DIRC( I) ,INM( l) ) , (INM(l) ,NROW) 
EQUIVALENCE ( INM(2 ) , ICOLS) , (DIRC(2 ) ,AMAX) , (DIRC( 3) .AMIN) 

C 

DATA NS0N/2HLF , 2HLT , 2HR , 2HDI , 2HNT, 2HP / 

CALL RMPAR(IPRAM) 

LU-IPRAM(l) 

IF(LU.EQ.O) LU-1 
C 

C INITIALIZE PARAMETERS 

C 

ITYPE » 8 
C 

CALL CODE 
WRITE (JMES, 6) 

6 FORMAT C* RESIZE") 

CALL TRMGN (JMES.LU.O) 

CALL BUNK (JMES) 

NTYPE-32 

IRTCD=0 

IMXX-512 

IMXPl-IMXX+1 

IFE=0 

ILE-511 

IFR a 0 

ILR-511 

C 

5 CALL CODE 

WRITE (JMES, 995) 

995 FORMAT (" RESIZE IMAGE ") 

CALL TRMGN (JMES.LU.O) 

CALL BUNK (JMES) 

C 

C SPECIFY DATA LENGTH FOR OUTPUT 

C 


27 


0053 

10 

CALL CODE 

0054 


WRITE(JMES,ll) 

0055 

11 

F0RMAT(“ SPECIFY OUTPUT DATA TYPE") 

0056 


CALL TRMGN( JMES , LU,0) 

0057 


CALL BLANK(JMES) 

0058 


CALL CjDE 

0059 


WRITE( JMES, 12) 

0060 

12 

FORMAT (" 1. 8 BIT IMAGE") 

0061 


CALL TRMGN(JMES,LU,0) 

0062 


CALL BLANK(JMES) 

0063 


CALL CODE 

0064 


WRITE( JMES, 13) 

0065 

n 

FORMAT(" 2. 15 BIT IMAGE") 

0066 

0067 

c 

CALL TRMGN( JMES, LU, 1 ,RTM, ICD, IRTM) 

0068 


IRTM-ICD 

0069 

c 


0070 


CALL BLAMK(JMES) 

0071 

15 

CALL SPCHR (IRTM.IRT) 

0072 


GO TO (500, 10, 5, 20, 17, 17), IRT 

0073 

17 

CALL CKFLD( 2 , ICD , IRS) 

0074 


GO TO (25, 25, 30, 30, 20), IRS 

0075 

20 

IW-l 

0076 


GO TO 950 

0077 

25 

ITYPE -8 

0078 


IMAX-255 

0079 


GO TO 32 

0080 

30 

ITYPE -15 

0081 

0082 

C 

I MAX-32767 

0083 

C 

SPECIFY WORK FILE 

0084 

C 


0085 

C 


0086 

32 

CALL BLANK( JMES) 

0087 


CALL CODE 

0088 


WRITE (JMES, 4 50) 

0089 

450 

FORMAT ( ” SELECT OPTION") 

0090 


CALL TRMGN( JMES,LU,0) 

0091 


CALL BLANK(JMES) 

0092 


CALL CODE 

0093 


WRITE (JMES, 4 55) 

0094 

455 

FORMAT ( " 1. SPECIFY NEW IMAGE") 

0095 


CALL TRMGN( JMES, LU,0) 

0096 


CALL BLANK( JMES) 

0097 


CALL CODE 

0098 


WRITE( JMES, 460) 

0099 

460 

FORMAT( " 2. USE CURRENT WORK FILE") 

0100 


CALL TRMCN( JMES , LU , l , RTM , ICD , IRTM ) 

0101 


CALL BLANK(JMES) 

0102 

465 

CALL CKFLD(2,ICD,IRS) 

0103 


GO TO (475, 475, 480, 485), IRS 

0104 

485 

IW-l 2 

0105 

C 


0106 

C 

OPEN WORK FILE 

0107 

C 



28 


0109 

0110 
01 L l 
0112 

0113 

0114 

0115 

0116 

0117 

0118 

0119 

0120 
0121 
0122 

0123 

0124 

0125 

0126 
0127 
0123 

0129 

0130 

0131 

0132 

0133 

0134 

0135 

0136 

0137 

0138 

0139 

0140 

0141 

0142 

0143 

0144 

0145 

0146 

0147 

0148 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158 

0159 

0160 
0161 
0162 

0163 

0164 

0165 

0166 

0167 

0168 

0169 

0170 

0171 

0172 


475 

480 

40 

45 


C 

C 

C 


50 


51 


52 


53 


54 


56 


57 


58 


55 


60 


C 

C 

C 


65 


C 

C 

C 


75 


«' j ij ■) jo 

IGET-WFINT ( NROW , ICOLS ,AMAX,AMIN, LU) 

IF(IGET.LT.O) GO TO 999 
IGET-READL( -1 ,0, 511 ,DIRC) 

IF( IGET.LT.O) CO TO 999 
CALL CODE 

WRITE(JMES,45) A MAX, AMIN 

FORMAT ( " AMAX- ”,E12.5,5X,” AMIN- “ ,E12. 5, 5X, "FOR IMAGE") 
CALL TRMCN( JMES , LU , 0) 

CALL BLANK(JMES) 

SPECIFY IMAGE SCALING OPTION 

CALL CODE 
WRITE( JMES , 51 ) 

FORMA T ( " SPECIFY IMAGE SCALING OPTION”) 

CALL TRMGN( JMES , LU,0) 

CALL BLANK( JMES) 

CALL CODE 
WRITE( JMES, 52) 

FORMAT( " 1. AUTOMATIC SCALING") 

CALL TRMGN( JMES, LU,0) 

CALL BLANK(JMES) 

CALL CODE 
WRITE( JMES, 53) 

FORMAT (" 2. SYSTEM DEFAULT OPTION" ) 

CALL TRMGN( JMES, LU,0) 

CALL BLANK(JMES) 

CALL CODE 
WRITE( JMES, 54) 

FORMAT ( " 3. USER SPECIFIED SCALE FACTOR") 

CALL TRMGN( JMES, LU.O) 

CALL BLANK(JMES) 

CALL CODE 
WRITE (JMES, 56) 

FORMAT ( " 4. USER SPECIFIED MAX AND MIN") 

CALL TRMGN ( JMES , LU , 0) 

CALL BLANK(JMES) 

CALL CODE 
WRITE( JMES , 57 ) 

FORMAT ( " 5. LOG COMPRESSION") 

CALL TRMGN( JMES, LU,0) 

CALL BLANK(JMES) 

CALL CODE 
WRITE( JMES, 58) 

FORMAT ( ” 6. EXPONENTIATION OPTION") 

CALL TRMGN( JMES, LU, l ,RTM. ICD.IRTM) 

CALL BLANK(JMES) 

CALL CKI-LD (6,ICD,IRS) 

GO TO (65, 65, 75, 80, 105, 160, 165,60), IRS 
IW*2 

GO TO 950 


AUTOMATIC SCALING SELECTED 
SCL-AMAX-AMIN 

IF (ABS(SCL) .LE. l.OE-5) GO TO 70 
SCL-FLOAT ( IMAX) /SCL 
IOPT-1 
GO TO ’90 

SYSTEM DEFAULT SCALING OPTION SELECTED 

SCL-1 .0 
I0PT=2 


JiGGTNAL PAGE IS 
OF POOR QT’AKTY 




0234 


CALL CODE 

0235 


WRITS(JMES,l5l) 

0236 

151 

FORMAT ( " SCALE TOO SMALL") 

0237 


CALL TRMGN( JMES, LU,0) 

0233 


CALL BLANK(JMES) 

0239 


CALL CODE 

0240 


WRITE( JMES, 152) 

0241 

152 

FORMAT (" ENTER CR TO GO TO SYSTEM LEVEL MENU") 

0242 


CA L L TRMGN ( JMES , LU , 1 , RTM , ICD , I RTM ) 

0243 


CALL BUNK (JMES) 

0244 


1RTCD-1HX 

02*5 


GO TO 1000 

0246 

155 

SCL-( 1 . 0 / S CL ) *FLOAT ( IMAX ) 

0247 


GO TO 190 

0248 

C 


0249 

C 

LOG COMPRESSION OPTION SELECTED 

0250 

c 


0251 

160 

CALL CODE 

0252 


WRITE( JMES, 161) 

0253 

161 

FORMAT ( " LOG COMPRESSION OPTION SELECTED") 

0254 


CALL TRMGN( JMES,LU,0) 

0255 


CALL BLANK(JMES) 

0256 


IOPT-5 

0257 


SCL-FLOAT(IMAX)/ALOG(AMAX-AMIN+1.0) 

0258 


GO TO 190 

0259 

C 


0260 

C 

EXPONENTIATION OPTION SELECTED 

0261 

C 


0262 

165 

CALL CODE 

0263 


WRITE( JMES, 166) 

0264 

166 

FORMAT ( " ENTER DESIRED EXPONENT") 

0265 


CALL TRMGN( JMES , LU , l , RTM , ICD , IRTM ) 

0266 


CALL BLANK (JMES) 

0267 

170 

CALL SPCHR (IRTM.IRT) 

0268 


POWER* RTM 

0269 


IF (IRT .EQ. 5) GO TO 180 

0270 

175 

IW=6 

0271 


GO TO 950 

0272 

180 

POWER*ABS( POWER) 

0273 


CALL CODE 

0274 


WRITE( JMES, 185) POWER 

0275 

185 

FORMAT ( " EXPONENT- ",IF10.4) 

0276 


CALL TRMGN(JMES, LU,0) 

0277 


CALL BLANK(JMES) 

0278 


SCL=FLOAT(IMAX)/((AMAX-AMIN)**POWER) 

0279 


IOPT-6 

0280 

C 


0281 

C 

OBTAIN PARAMETERS FOR RESIZING IMAGE 

0282 

C 


0283 

190 

INUM-64 

0284 


INCNT-0 

0285 


IMCNT-0 

0286 


NTST-INUM 

0287 

195 

CALL CODS 

0288 


WRITE( JMES, 196) 

0289 

196 

FORMAT ( " INDEPENDENT DIRECTIONAL SCALING") 

0290 


CALL TRMGN( JMES, LU,0) 

0291 


CALL BLANK(JMES) 


0174 

0175 

0176 

0177 

0178 

0179 

0180 
0181 
0182 

0183 

0184 

0185 

0186 

0187 

0188 

0189 

0190 

0191 

0192 

0193 

0194 

0195 

0196 

0197 

0198 

0199 

0200 
0201 
0202 

0203 

0204 

0205 

0206 

0207 

0208 

0209 

0210 
0211 
0212 

0213 

0214 

0215 

0216 

0217 

0218 

0219 

0220 
0221 
0222 
0223 

224 

0225 

0226 
0227 
0223 

0229 

0230 

0231 

0232 

0233 


C 

C USER ENTERS SCALE FACTOR 

C 

80 CALL CODE 

WRITE (sTMES, 81) 

81 FORMATC ENTER DESIRED SCALE FACTOR") 

CALL TRMGN( JMES , LU , i ,RTM, ICD, tRTM) 

CALL BLANK( JMES) 

85 CALL SPCHR (IRTM.IRT) 

GO TO (1000, 1000, 1000, 1000, 855), IRT 
855 GAIN-ABS(RTM) 

IF (IRT .EQ. 5) GO TO 95 
90 IW»3 

GO TO 950 
95 CALL CODE 

WRITE( JMES, 100) GAIN 

100 FORMAT (” SCALE FACTOR - ”,F10.4) 

CALL TRMGN( JMES,LU,0) 

CALL BUNK(JMES) 

I0PT-3 
SCL-GAIN 
GO TO 190 
C 

C USER SPECIFIED MAXIMUM AND MINIMUM 

C 

105 IOPT=4 

CALL CODE 
WRITE( JMES, 106) 

106 FORMATC ENTER MAXIMUM FOR IMAGE") 

CALL TRMGN( JMES , L'J , 1 , RTM , ICD , IRTM ) 

CALL BLANK(JMES) 

110 CALL SPCHR (IRTM.IRT) 

GO TO (1000, 1000, 1000, 1007,910) , IRT 
910 AMXIN=RTM 

IF(RTM.NE.OB) CO TO 120 
115 IW=4 

GO TO 950 

120 CALL CODE 

WRITE( JMES, 121) AMXIN 

121 FORMATC’ MAXIMUM FOR IMAGE ■ ”,1PE15.8) 
CALL TRMGN( JMES, LU,0) 

CALL BLANK(JMES) 

130 CALL CODE 

WRITE( JMES, 131) 

131 FORMATC ENTER MINIMUM FOR IMAGE" ) 

CALL TRMGN( JMES , LU , 1 , RTM , ICD , I RTM ) 

CALL BLANK(JMES) 

135 CALL SPCHR (IRTM.IRT) 

GO TO (1000, 1000, 1000,1000, 935), IRT 
935 AMNIN=RTM 

IF (IRT .EQ. 5) G'i CO 145 
140 IW=5 

GO TO 950 
145 CALL CODE 

WRITE( JMES, 150) AMN1N 

150 FORMAT ("— MINIMUM FOR IMAGE -”,F10.4) 
CALL TRMGN( JMES, LU,0) 

CALL BIANK( JMES) 

SCL=AMXIN-AMNIN 
IF(SCL.GE. 1.0E-5) GO TO 155 


31 


0292 

931 

CALL CODE 


0293 


WRITE(JMES, 197) 


0294 

197 

F0RMAT(" ENTER ROW SCALE FACTOR") 


0295 


CALL TRMGN( JMES , LU , l , RTM , ICD , IRTM) 


0296 


CALL BLANK(JMES) 


0297 

200 

CALL SPCHR (IRTM, IRT) 


0298 


YS-RTM 


0299 


IF (IRT .EQ. 5) GO TO 210 


0300 

205 

IW-7 


0301 


GO TO 950 


0302 

210 

CALL CODE 


0303 


WRITE( JMES, 211) 


0304 

211 

FORMAT ( " ENTER COLUMN SCALE FACTOR ") 


0305 


CALL TRMGN(JMES,LU,1,RTM,ICD,IRTM) 


0306 


CALL BLANK(JMES) 


0307 

215 

CALL SPCHR (IRTM,I r T) 


0308 


XS-RTM 


0309 


IF (IRT .EQ. 5) GO TO 225 


0310 

220 

IW-8 


0311 


GO TO 950 


0312 

C 



0313 

C 

CHECK TO SEE IF INTERPOLATION IS REQUIRED. IF NOT 

BRANCH. 

0314 

C 



0315 

C 



0316 

C 

COMPUTE NEW SIZE OF IMAGE 


0317 

C 



0313 

225 

NNE W = Y 5 * N ROW+ . 5 


0319 


NCOLS=XS*ICOLS+. 5 


0320 

C 



0321 


IF(XS.EQ. 1 .O.AND.YS.EQ. 1.0) GO TO 260 


0322 


IF(NCOLS.LE. 512) GO TO 230 


0323 


CALL CODE 


0324 


WRITE (JMES, 6 90) NCOLS.XS 


0325 

690 

FORMAT (" CALCULATED COLUMN SIZE = ",1I5,"(SF , 

1F5.2 M ) M ) 

0326 


CALL TRMGN( JMES, LU,C) 


0327 


CALL BLANK(JMES) 


0328 


CALL CODE 


0329 


WRITE (JMES, 969) 


0330 

969 

FORMAT (" 512 IS MAXIMUM ALL0WA3LE OUTPUT") 


03 Jl 


CALL TRMGN (JMES,L'J,0) 


0332 


CALL BLANK(JMES) 


0333 


CALL CODE 


0334 


WRITE( JMES, 226) 


0335 

226 

FORMATC REENTER COLUMN SCALE FACTOR") 


0336 


CALL TRMGN( JMES , LU , 1 , RTM , ICD , IRTM ) 


0337 


CALL BLANK(JMES) 


0338 


GO TO 215 


0339 

O 

CM 

CALL CODE 


0340 


WRITE( JMES.695) NNEW.YS, NCOLS.XS 


0341 

695 

FORMAT("— OUTPUT IMAGE-" , 14X, "ROWS = ",1I5,"(SF= 

” , 1F5 . 2, ”) 

0342 

*14X, "COLUMNS = " , 115 , " (SF =* " , 1F5. 2, ")") 


0343 

231 

CALL TRMGN( JHES,LU,0) 


C344 


CALL BLANK(JMES) 


0345 


CALL CODE 


0346 


WRITE( JMES, 1232) 


0347 

1232 

FORMATC 1. VALUES OKAY") 


0348 


CALL TRMGN( JMES , LU,0) 


0349 


CALL BLANK(JMES) 



0350 

0351 

0352 

0353 

0354 

0355 

0356 

0357 

0358 

0359 

0360 

0361 

0362 

0363 

0364 

0365 

0366 

0367 

0368 

0369 

0370 

0371 

0372 

0373 

0374 
03/5 

0376 

0377 

0378 

0379 
0330 

0381 

0382 

0383 

0384 

0385 

0386 

0387 
0383 

0389 

0390 

0391 

0392 

0393 


CALL CODE 
WRITE(JMES, 1233) 

1233 FORMAT ( " 2. REENTER SCALE FACTOR") 

CALL TRMGN(JMES,LU,1 ,RTM,ICD,IRD1) 

CALL 3LANK( JMES) 

232 CALL SPCHR (IRTM.IRT) 

CALL CKFLD( 2, ICD, IRS) 

GO TO (234, 234, 931), IRS 
233 IW-9 

GO TO 950 
C 

C COMPUTE INCREMENTS FOR INTERPOLATION 
C 

234 MM-NNEW 
IFLT-0 

DY=FLOAT(NROW ) / FLOAT ( NNEW) 

DX=FLOAT( ICOLS ) /FLOAT( NCOLS ) 

IF(DY.LE.l.O) GO TO 235 
700 CALL CODF 

WRITE( JMES ,1750) 

1750 FORMAT ( " IMAGE SHOULD BE FILTERED BEFORE INTERPOLATION") 
CALL TRMGN( JMES, LU,0) 

CALL BLANK(JMES) 

CALL CODE 
WRITE (JMES, 9750) 

9750 FORMAT (" TO PREVENT ALIASING") 

CALL TRMGN( JMES, LU,0) 

CALL BLANK(JMES) 

CALL CODE 
WRITE( JMES, 760) 

760 FORMA T( ” 1. CONTINUE ") 

CALL TRMGN( JMES , LU,0) 

CALL BLANK(JMES) 

WRITE( JMES, 761) 

761 FORMAT ( " 2. PREFILTER IMAGE") 

CALL TRMGN( JMES , LU , l , RTM , ICD , I RTM ) 

704 CALL SPCHR (IRTM.IRT) 

GO TO (1000, 1000, 1000, 1000, 904), IRT 
904 CALL CKFLD( 2 , ICD, IRS) 

GO TO (702,702, 710), IRS 
710 IW-10 

GO TO 950 
C 

C SCHELULE FILTER TO PREVENT ALIASING 


0394 

0395 

0396 
039/ 

0398 

0399 

0400 

0401 

0402 

0403 

0404 

0405 

0406 


p 

702 FCX=0 . 8*FL0AT(NC0LS) /FLOAT ( ICOLS) 

FCY=0. 8*FL0AT ( NNEW ) /FLOAT ( NROW ) 

NX=2 

NY=2 

ITME=0 

CALL XYFLT( U , V , FCX ,FCY ,NX ,NY ,N ,A , B) 
C 

DO 705 11=1,3 
705 NAME(II)=NSON(II , 1) 

CALL EXEC ( 9, NAME, LU,0, NCOLS -1) 

C 

C INI" - LIZE FOR RESIZING 


0407 

C 


0403 

:35 

CALL CODE 

0409 


WRITE(JMES,810) 

0410 

310 FORMAT (“ RESIZING OF IMAGE IN PROGRESS") 

0411 


CALL TRMGN( JMES , LU , 0) 

0412 


CALL BLANK(JMES) 

0413 

C 


0414 

C 

SCHEDULE DINTP FOR RESIZING IMAGE 

0415 

C 


0416 


INCW-LU+200B 

0417 


DO 250 11-1,3 

0413 

250 

NAME(II)-NSON(II, 2) 

0419 

C 


0420 

C 

CLOSE WORK FILE 

0421 

C 


0422 


CALL CLSWF ( NROW , ICOLS , AMAX , AMIN) 

0423 


CALL EXEC( 1 3 , ICNW , IPRAM( 3 ) , IPRAM( 4 ) , IPRAM( 5 ) ) 

0424 


CALL EXEC( 23 , NAME , IPRAM( 1 ) , NNEW , NCOLS , IPRAM( 4 ) , IPRAM( 5 ) ) 

0425 

C 


0426 

C 

OPEN WORK FILE 

0427 

C 


0423 

C 


0429 

C 


0430 

C 

CALL OPEN(IDCB, IGET, 6HW10000, 2,0,0, 528) 

0431 

C 

IF(IGET.LT.O) GO TO 999 

0432 

C 


0433 

C 

REMAP INTENSITY VALUES FOR IMAGE 

0434 

c 


0435 

c 

OBTAIN NEW SIZE PARAMETERS 

0436 

c 


0437 

c 


0438 


IGET=READL(-1,0, 511,DIRC) 

0439 


IF(IGET.LT.O) GO TO 999 

0440 

c 


0441 

260 

IMCNT-0 

0442 


IZCNT-0 

0443 


DO 405 NN=l,NROW 

0444 

C 


0445 

C 

READ IN NEW ROW 

0446 

C 


0447 


NNM1-NN-1 

0448 


IGET=READL(NNM1 ,IFE, ICOLS-1 ,F) 

0449 


IF(IGET.LT.O) GO TO 999 

0450 


IF (IOPT .GT. 6) GO TO 310 

0451 


GO TO (306, 310, 320, 330, 340, 350), IOPT 

0452 

306 

DO 305 1=1, ICOLS 

0453 

305 

G(I)=(F(I)-AMIN)*SCL+0. 5 

0454 


GO TO 360 

0455 

310 

DO 315 1=1, ICOLS 

0456 

315 

G(I)=F(I)+0. 5 

0457 


GO TO 360 

0458 

320 

DO 325 1=1, ICOLS 

0459 

325 

G(I)=(F(I)*SCL+0. 5) 

0460 


GO TO 360 

0461 

330 

DO 335 1=1, ICC LS 

0462 

335 

G(I)=(F(I)-AMNIN)*SCL+0.5 

0463 


GO TO 360 

0464 

340 

DO 345 1=1, ICOLS 

0465 


F(I)=AMAX1(F(I),AMIN) 

0466 

345 

G(I)=SCL* (AL0G(F ( I )-AMIN+l . 0) )+0 . 5 

0467 


GO TO 360 

0463 

350 

DO 355 1=1, ICOLS 

0469 

355 

G(I)=SCL*(F(I)-AMIN)**PCWER+0.5 


34 


0470 

C 


0471 

C 

WRITE OUTPUT TO WORK FILE 

0472 

c 


0473 

360 

IGET-RITEL( NNM1 , 0 , I COLS- 1 , C ) 

0474 


IF(IGET.LT.O) GO TO 999 

0475 

C 


0476 

C 

IF OUTPUT IS 8 BIT, WRITE TO DISPLAY 

0477 

C 


0473 


IF(ITYPE.EQ.l5) GO TO 365 

0479 

C 


0480 


DO 370 I-l.ICOLS 

0481 


I F ( G ( I ) . GT . ( FLOAT ( IMAX ) +0 . 5 ) ) IMCNT « IMCNT+l 

0482 


IF(G(I) .LT.O.O) IZCNT-IZCNT+l 

0483 


IOP( I )-MINO( IFIX(G( I) ) , IMAX) 

0484 

370 

IOP( I )-MAXO( IOP( I ) , 0) 

0485 

365 

IF(NN.LT.NTST) GO TO 400 

0486 


NTST-NTST+INUM 

0487 


CALL CODE 

0488 


WRITE( JMES.375) NN.NNEW 

0489 

375 

FORMAT (**- RESIZE ROWS DONE/ TO DO ", 114, ’7'*, 114 

0490 


CALL TRMGN( JMES,LU,0) 

0491 


CALL BLANK(JMES) 

0492 

C 


0493 

400 

IF(ITYPE.NE.8) GO TO 405 

0494 


IGET-WLINE(NNM1 , 00 , ICOLS-1 , IOP) 

0495 


IF(IGET.LT.O) GO TO 999 

0496 

405 

CONTINUE 

0497 

C 


0493 

C 

CLOSE WORK FILE 

0499 

C 


0500 


AMAX=FLOAT(IMAX) 

0501 


AMIN=0 . 0 

0502 


CALL CLSWF(NROW,ICOLS ,AMAX,AMIN) 

0503 


IRTCD=0 

0504 


IT0T=NR0W*IC0LS 

0505 


AT0T=* 1 00 . 0/FL0AT( ITOT ) 

0506 


PZER0=AT0T*FL0AT( IZCNT ) 

0507 


PMAX=ATOT*FLOAT ( IMCNT ) 

0508 


IF(PZERO.EQ.O.O .AND.PMAX.EQ.O.O) GO TO 1000 

0509 


CALL CODE 

0510 


WRITE( JMES.410) PZERO, PMAX 

0511 


CALL TRMCN(JMES,LU,0) 

0512 


CALL BLANK(JMES) 

0513 

410 

FORMAT ( PERCENT CLIPPED AT ZERO =”,F6.2, 

0514 


1" - PERCENT CLIPPED AT MAX «”,F6.2) 

0515 

420 

CALL TRMGN( JMES, LU,0) 

0516 


CALL BLANK(JMES) 

0517 


CALL CODE 

0518 


WRITE (.JMES, 421) 

0519 

421 

FORMAT ( " 1. CONTINUE! 2. RESCALE IMAGE”) 

0520 


CALL TRMGN( JMES , LU , l , RTM , ICD , I RTM ) 

0521 


CALL BLANK(JMES) 

0522 

425 

Call SPCHR (IRTM,IRT) 

0523 


GO TO (1000, 1000, 1000, 1000, 92 5 ),IRT 

0524 

925 

CALL CKFLD(2,ICD,IRS) 

0525 


GO TO (1000, 1000, 440, 430), IRS 

0526 

430 

IW*11 

0527 


GO TO 950 


35 


0528 

440 

CALL READL(-i,0,5il,DIRC) 

0529 


GO TO 5 

0530 

70 

CALL CODE 

0531 


WRIT£( JMES, 921) 

0532 

921 

FORMAT (' SCALING SIZE ERROR') 

0533 


CALL TRMGN( JMES,LU,0) 

0534 


CALL BLANK(JMES) 

0535 

500 

CONTINUE 

0536 


GO TO 999 

0537 

950 

CALL CODE 

0533 


WRITE (JMES, 21) 

0539 

21 

FORMAT (" /INVALID SELECTION/”) 

0540 


CALL TRMGN ( JMES, LU, 1 ,RTM,ICD,IRTM) 

0541 


CALL BLANK (JMES) 

0542 


GO TO (15, 55, 85, 110, 135, 170, 200, 215, 232, 704, 425), IW 

0543 

999 

IF( IGET.EQ.-8) CALL CLSWF(NROW, ICOLS ,AMAX,AMIN) 

0544 

1000 

CALL EXEC(6) 

0545 


END 

0546 

$ 


0547 

$ 



&R0T8 T =>00004 IS ON CROO022 USING 00002 BLKS R=»0014 


ASMB,R,L,C 


0001 
0002 

0003 

0004 

0005 * 

0006 WORD 

0007 OUT 

0008 * 

0009 ROTS 

0010 
0011 
0012 

0013 

0014 

0015 

0016 


NAM ROT8.6 
ENT R0T8 
EXT . ENTR 

BSS 1 
BSS 1 

NOP 

JSB .ENTR 
DEF WORD 
LDA WORD, I 
ALF.ALF 
STA OUT, I 
JMP ROTS, I 
END 


&TRMGN T-00004 IS ON CR00022 USING 00056 BLKS R-0439 


0001 FTN4.L 

0002 SUBROUTINE TRMGN( JMES, LU,IP,RTM,ICD,IRTM) 

0003 C 

0004 C THIS SUBROUTINE IS USED TO WRITE OUT AND POSSIBLY READ BACK 

0005 C FROM THE TERMINAL INFORMATION NECESSARY FOR PROGRAM CONTROL. 

0006 C JMES IS TRHE MESSAGE TO BE OUTPUT TO THE LU. IP (IF -0) MEANS 
j007 C WRIE ONLY, (IF -1) MEANS TO WAIT FOR A RESPONSE FROM THE OPERAT 

0008 C RTM IC THE RETURN FOR REAL NUMBERS, ICD IS A RETURN FOR INTEGER 

0009 C I RTM IS THE RETURN FOR ASCII CHARACTERS. ALL THREE TYPES OF RES 

0010 C ARE GENERATED EACH TIME THIS SUBROUTINE IS CALLED. THE MAXIMUN 

0011 C OUTPUT MESSAGE IS 80 CHARACTERS LONG. THE MAXIMUN INPUT MESSAGE 

0012 C 10 CHARACTERS LONG. 

0013 C 

0014 DIMENSION JMES(40) ,IRTM(5) 

0015 ICNWD-400B+LU 

0016 C WRITE THE MESSAGE TO THE LU 

0017 CALL EXEC ( 2 , ICNWD , JMES , 40) 

0013 IF (IP .EQ. 0) RETURN 

0019 C READ THE MESSAGE BACK FROM THE LU 

0020 CALL EXEC ( 1 , ICNWD, IRTM.5) 

0021 CALL CODE 

0022 READ (IRTM,*)ICD 

0023 CALL CODE 

0024 READ (IRT>1,*)RTM 

0025 RETURN 

0026 END 

0027 SUBROUTINE XYFLT(U,V,FCX,FCY,NX,NY,N,A,B) 

0023 C 

0029 C WRITTEN BY W.E. ALEXANDER 

0030 C SUBROUTINE FORM A PART OF THE SPATIAL 

0031 C DOMAIN FILTERING PACKAGE. 

0032 C LOW PASS RECURSIVE FILTER DESIGN ROTINE 

0033 C WITH FCX NOT EQUAL TO FCY . 

0034 C FCX=RCX*S/PI WHERE RCX IS THE CUTOFF 

0035 C FREQUENCY IN THE X DIRECTION AND S IS THE SAMPLING 

0036 C INTERVAL (X DIRECTION) 

0037 C FCY - RCY*S/PI WHERE RCX IS THE CUTOFF 

0038 C THE Y DIRECTION AND S IS THE SAMPLING INTERVAL 

0039 C (Y DIRECTION) 

0040 C (0. 010. LE. FCX. LE. 0.950) 

0041 C (0. 010. LE. FCY. LE. 0.950) 

0042 C 

0043 COMPLEX P 

0044 DIMENSION U(3, 3, 2) , V(3 , 3, 2) ,A(3 , 2, 2) ,B(3 , 2, 2) 

0045 C 

0046 PI=3. 141592654 

0047 D = 1.0E-10 

0048 N = 3 

0049 IF(NX.LE.2.AND.NY.LE. 2)N=2 

0050 EPS - 1.0 

0051 DO 6 1=1,18 

0052 IF (I.GT. 12) GO TO 7 

0053 A(I)=0 

0054 B(I)=0 

0055 7 U(I)=0 

0056 6 V(I)=0 

0057 C 






37 


0058 


A(l,2,l) - 1.0 

0059 


A(l,2,2) - 1.0 

0060 


B(i,2,l) - 1.0 

0061 


8( 1 ,2 , 2) - 1.0 

0062 

C 


0063 


NXP - NX-1 

0064 


TX - SIN( PI*FCX*0. 5) /C0S(PI*FCX*0 

0065 


TX - TX**2 

0066 


IF(TX.LE.D)TX«D 

0067 


CNX - TX**NXP/EPS 

0068 


DX - C. 25 

0069 


IF(NX.EQ. 3)DX"0. 125 

0070 


DX - CNX**DX 

0071 

C 


0072 


NYP - NY-1 

0073 


TY - SIN( PI*FCY*0. 5)/C0S(PI*FCY*0 

0074 


TY“TY**2 

0075 


IF(TY.LE.D)TY-D 

0076 


CNY - TY**NYP/EPS 

0077 


DY - 0.25 

0078 


IF(NY.EQ.3)DY-0.125 

0079 


DY - CNY**DY 

0080 

C 

CALCULATE COEFFICIENTS 

0081 

C 


0082 


NNN-N-1 

0083 


DO 10 J-l.NNN 

0084 


DO 10 K - 1,2 

0085 


iF(K.EQ. 2) GO TO 20 

0086 


CN - CNX 

0087 


DD - DX 

0083 


IF (NX.EQ.3) GO TO 22 

0089 


THT - 135.0*PI/180.0 

0090 


GO TO 23 

0091 

22 

IF(J.EQ.l)THT-) 12 . 5*PI/180.0 

0092 


IF(J.EQ. 2)THT=1 57. 5*PI/ 180.0 

0093 


GO TO 23 

0094 

20 

CN=CNY 

0095 


DD =* DY 

0096 


IF (NY.EQ.3) GO TO 21 

0097 


THT= i 35. 0*PI/ 180.0 

0098 


GO TO 23 

0099 

21 

IF( J. EQ . 1 )THT=1 12. 5* PI/1 80.0 

0100 


IF( J.EQ. 2)THT=157 . 5*PI/180.0 

0101 

23 

ALP=COS(THT) 

0102 


BET =■ SIN(THT) 

0103 


SI - i.O+ALP*DD 

0104 


S2 = 1 . 0-ALP*DD 

0105 


S3 ~ BET*DD 

0106 


S4— S3 

0107 


P=CMPLX(S1 ,S3)/CMPLX(S2 ,S4) 

0108 


SI - -2*REAL(P) 

0109 


S2 « (CABS( P) )**2 

0110 

C 



33 


oin 



AA - 0.25 * ( 1.0 + SI +S2 ) 


0112 



A( l , J, K) - AA 


0113 



A(2,J,K) - 2 . 0*AA 


0114 



A(3,J,K) - AA 


0115 



B( 1 , J ,K) - 1.0 


0116 



B(2,J,K) - SI 


0117 

10 


B(3,J,K)-S2 


0118 

C 




0119 

C 


OBTAIN TOO DIMENSION FILTER 


0120 

C 




0121 



IF6NX.EQ. 3)GO TO 30 


0122 



A( 1 , 2 , 1) - 1.0 


0123 



B(l,2,l) - 1.0 


0124 

30 


IF(NY.EQ. 3)GO TO 31 


0125 



A( 1 , 2 , 2) - 1.0 


0126 



B( 1 , 2 , 2) - 1.0 


0127 

C 




0128 

31 


DO 40 I - 1,3 


0129 



DO 40 J - 1,3 


0130 



DO 40 K - 1,2 


0131 



U(I.J.K) “ A(I,K,l)*A(J,K,2) 


0132 

40 


V(I,J,K) - B(I,K,1)*B(J,K.,2) 


0133 



RETURN 


0134 



END 


0135 

C 

*************** ***siJBROUTINE intrp* ************* *********** 

0136 

C/L60 



0137 

C 

****** ************SUB ROUTINE I NTRP* *** ** *********** ******** 

0138 

C 

* 


* 

0139 

C 

* 

THIS SUBROUTINE IS FOR INTERPOLATING POINTS IN AN ARRAY 

* 

0140 

C 

★ 


* 

0141 

C 

****** *******SU3^0UTINE variables************************** 

0142 

C 

* 

AINT: STORAGE ARRAY FOR DATA POINTS 

* 

0143 

C 

* 

Y: THE DISTANCE BETWEEN LINES OF DATA POINTS 

* 

0144 

C 

it 

DX: INTERVAL VALUE BETWEEN INTERPOLATING POINTS 

* 

0145 

c 

it 

NCOLS: NUMBER OF POINTS REQUIRED PER ROW IN OUTPUT 

* 

0146 

c 

it 

ICOLS: NUMBER OF POINTS TO PER ROW IN INPUT 

* 

0147 

c 

it 

FOP: THE OUTPUT ARRAY 

* 

0148 

c 

*********************************************************** 

0149 

c 




0150 

c 




0151 



SUBROUTINE INTRP(AINT,Y,DX, NCOLS, ICOLS, FOP) 


0152 



DIMENS IOt: AINT(i), FOP( 1) ,JMES(40) 


0153 



CALL CODE 


0154 



WRITE (JMES, 150) 


0155 

150 

FORMAT(' NOW IN INTRP ' ) 


0156 



CALL TRMGN( JMES, LU,0) 


0157 

C 




0158 



IMAX*512 


0159 



IMXP-IMAX+1 


0160 



ICM1=>IC0LS-1 


0161 



1*1 


0162 



M=I 


0163 

15 

X*( 1-1 )*DX-(M-1 ) 


0164 



IF(X.LT.l.O) GO TO 25 


0165 



M=*M+1 


0166 



IF(M.GT.ICMl) GO TO 50 


0167 



GO TO 15 


0168 

25 

E - (A INT ( M+l ) -A INT ( M ) )*X+A I NT ( M ) 


0169 



F=(AINT(M+IMXP)-AINT(M+IMAX))*X+AINT(M+IMAX) 


0170 



FOP(I)=’(F-E)*Y+E 
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0171 

0172 

0173 

0174 

0175 

0176 

0177 

0178 
w79 
0180 
0181 
0182 
0183 


I-l+l 

IF(I.LE.NCOLS) GO TO 15 
IF(X.LT.l.O.AND.I.GT.NCOLS) GO TO 51 
C 

C COMPLETE INTERPOLATION 

C 

50 FOP( NCOLS ) -(A INT( ICOLS+IMAX)-AINT( ICOLS ) )*Y+A INT( ICOLS ) 

51 CALL CODE 

WRITE(JMES, 150) 

160 FORMATC NOW LEAVING INTRP') 

CALL TRMGN(JMES, LU,0) 

RETURN 

END 


&LBRSZ T •■00004 IS ON CR00022 USING 00010 BLKS R-0100 


0001 

FTN4 

,L 

0002 


SUBROUTINE SPCHR ( IRTCD, IRT) 

0003 

C 


0004 

C 

THIS ROUTINE CHECKS FOR SPECIAL CHARACTERS IN THE INPUT DATA 

0005 

C 


0006 


IRT- 5 

0007 


IF (IRTCD.EQ. OB) IRT-0 

0008 


IF ((IRTCD.EQ. 1HX) .OR. (IRTCD .EQ. 2HX ))IRT-1 

0009 


IF ( (IRTCD.EQ. 1HB) .OR. (IRTCD .EQ. 2HB ))IRT-2 

0010 


IF ((IRTCD.EQ. 1HD) .OR. (IRTCD .EQ. 2HD ))IRT-3 

0011 


IF ( (IRTCD.EQ. 1HR) .OR. (IRTCD .EQ. 2KR ))IRT-4 

0012 


RETURN 

0013 


END 

0014 


SUBROUTINE CKFLD(IA ,ICD,IRS) 

0015 

c 


0016 

c 

SUBROUTINE TO CHECK FOR CARRIAGE RETURN OR NUMERIC VALUE 

0017 

C 


0018 


IRS-ICD+1 

0019 


IF (ICD .EQ. OB) IRS-1 

0020 


RETURN 

0021 


END 

0022 


SUBROUTINE INFRM (IA,LU) 

0023 


DIMENSION L\(3) 

0024 


ICNWD-400B +LU 

0025 


CALL EXEC (2, ICNWD, IA , 3) 

0026 


RETURN 

0027 


END 

0028 

c 


0029 

c 


0030 


SUBROUTINE XFLTR(A INT , ICOLS , F ,A , B , FCX, ITME ) 

0031 


DIMENSION B(3,2) 

0032 


DIMENSION F(1),AIN'T(1),A(3,2),WF(3),WG(3) 

0033 

c 

IF (ITME.EQ. 0) CALL BOOST(0.0, l.0,FCX,2,A,B) 

0034 


ITME-ITME+l 

0035 


Al-A(l,l) 

0036 


A2=A(2, 1) 

0037 


A3=A( 3 , 1 ) 

0038 


B2-B(2,l) 

0039 


B3-B(3,l) 

0040 

c 



40 


0041 

G 

INITIALIZE 

0042 

C 


0043 


IrtAX-512 

0044 


IN’T-ICOLS/2-i 

0045 


IMXPl-IMAX+l 

0046 


ASTT-AINT( INT)4AINT( INT+i)+AINT( INT+2) 

0047 


ASTT-ASTT/3 

0048 


DO 10 1-1,3 

0049 


VF(I)-ASTT 

0050 

10 

WC(I)-*STT 

0051 

c 


0052 

c 

START FORWARD FILTER 

0053 

G 


0054 


MM-IMXPl 

0055 


WF( l)-AINT(IMXPi) 

0056 

20 

WG(l)-Al*WF(l)4A2*WF(3)+A3*WF(3)-B2*WG(2)-B3*WG(3) 

0057 

C 


0058 

C 

UPDATE 

0059 

C 


0060 


A INT(MM)-WG( 1 ) 

0061 


WG(3)-WG(2) 

0062 


WG(2)-WG(1) 

0063 


WF(3)-WF(2) 

0064 


WF(2)-WF(1) 

0065 


MM-MM+l 

0066 


IF (MM.GT. ICOLS) GO TO 30 

0067 


WF( 1 )«AINT(MM) 

0068 


GO TO 20 

0069 

C 


00 70 

C 

START REVERSE FILTER 

0071 

C 


0072 

30 

astt-a;cnt(int) 

0073 


DO 40 1-1,3 

0074 


WF(I)-ASTT 

0075 

40 

WG( I )-ASTT 

0076 

n 

U 


C07 7 


MM-IMAX+ICOLS 

0078 


WF( I ) -A INT (MM ) 

0079 

4! 

WC(l)-Al*WF(l)+A2*WF(2)+A3*WF(3)-B2*WG(2)-B3*WG(3) 

0080 

C 


0081 

0 

UPDATE 

0082 

c 


0083 


A I NT ( MM ) -WG ( 1 ) 

0084 


WG(3)=WG(2) 

0085 


WG(2)-WG( L ) 

0086 


WF(3)=WF(2) 

0087 


WF(2)-WF( 1 ) 

0088 


MM-MM-l 

0089 


IF (MM .LE. IMAX) GO TO 50 

0090 


WF( l)-AINr(MM) 

0091 


GO TO 41 

0092 

50 

RETURN 

0093 


END 

0094 


SUBROUTINE BLANK (JMES) 

0095 


DIMENSION JMES (40) 

0096 


DO 10 1-1,40 

0097 

10 

JMES( I )-?M 

0098 


RETURN 

0099 


END 

0100 


END 5 


41 


&WFINT T-00004 IS ON CR00022 USING 00006 BLKS R-0044 


0001 FTN4 

0002 INTEGER FUNCTION WFINT(NLINE, NPIXL, PMAX, PMIN.IU) 

0003 C 

0004 C 

0005 C THIS SUBROUTINE IS USED IN CONJUNCTION WITH IMAGE PROCESSING 

0006 C IT CREATES AND MAINTAINS AN IMAGE WORK FILE WITH PIXEL VALUES 

0007 C STORED AS REAL NUMBERS TO PRESERVE PRECISION. 

0008 C 

0009 C this ONE INITIALIZES THE PROCESS BY CREATING THE WORK FILE 

0010 C AND RETURNING CERTAIN PERTINENT INFO TO CALLER. IT SHOULD 

0011 C ONLY BE CALLED ONCE BY EACH CALLER. THE OTHER TWO ARE 

0012 C READL, WHICH READS A PARTICULAR LINE AND RITEL WHICH WRITES 

0013 C A PARTICULAR LINE. 

0014 C 

0015 C LU INTERACTIVE TERMINAL LU 

0016 C 

0017 C NLINE - If LINES IN IMAGE 

0018 C NPIXL - If PIXELS/LINE 

0019 C PMAX - MAXIMUM PIXEL INTENSITY IN IMAGE (REAL) 

0020 C PM IN - MINIMUM PIXEL INTENSITY IN IMAGE (REAL) 

0021 C 

0022 C 

0023 DIMENSION IDCBI ( 144 ), IRTN( 5) , 13(6) 

0024 C 

0025 EQUIVALENCE ( IB2 , 18(2 ) ) , ( IB( 3) , RMAX) , ( IB( 5) , RMIN) 

0026 C 

0027 C 
0023 C 

0029 C SCHEDULE BUILD WORK FILE PROGRAM 

0030 C 

0031 CALL EXEC( 23 , 6HBLDWF ,LU) 

0032 C 

0033 C GET RETURNED PARAMETERS 

0034 C 

0035 CALL RMPAR(IRTN) 

0036 WFINT =» IRTN 

0037 IF (IRTN .LT.O ) RETURN 

0038 C 

0039 C GET MAX MIN DATA 


0040 C 

0041 

0042 

0043 C 

0044 

0045 

0046 

0047 

0048 

0049 

0050 

0051 

0052 

0053 C 

0054 100 
00 • 5 

r 


CALL OPEN(lDCBl,IERR,6HWFOOOO) 
IF ( I ERR .LT. 0) GO TO 100 

CALL READF( IDCBI ,IERR, IB ,6) 

IF (IERR .LT. 0) GO TO 100 

NLINE - IB 

NPIXL - IB2 

PMAX - RMAX 

PMIN - RMIN 

CALL CLOSE! IDCBI) 

WFINT - 0 
RETURN 

WFINT - IERR 
CALL CLOSE (IDCBI) 

END 
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0058 

0059 

0060 
0061 
0062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

0078 

0079 

0080 
0081 
0082 

0083 

0084 

0085 

0086 
0087 
0083 

0089 

0090 

0091 

0092 

0093 

0094 

0095 

0096 

0097 

0098 

0099 

0100 
0101 
0102 

0103 

0104 

0105 

0106 

0107 

0108 

0109 

0110 
0111 
0112 
0113 
01.14 


C 

C READ LIKE FROM WORK FILE SUBROUTINE 

C 

C 

INTEGER FUNCTION READL(L1NE, IPIXL, JPIXL, RBUF) 
C 

COMMON /CBLK/IDCB( 528) ,TBUF( 512) , IFLAG 
C 

DIMENSION RBUF(512) 

C 

C 

C CHECK IF FILE OPEN 
C 

IF ( IFLAG .EQ. 1) GO TO 100 
C 

C MUST OPEN FILE 
C 

CALL 0PEN( IDCB , IERR, 6HWF0000, 2 ,0 , 0,528) 

IF (IERR .LT. 0) GO TO 999 
IFLAG - l 
C 

C FILE OPENED— READ APPROPRIATE LINE 
C 

100 CALL READF(IDCB, IERR, TBUF, 1024, LEN.LINE+2) 

IF (IERR .LT. 0) GO TO 999 
C 

C POSITION DATA IN BUFFER 
C 

ISTEP - 1 

IF ( IPIXL .GT. JPIXL) ISTEP - -1 
C 

J - 1 

DO 110 I-IPIXL+1 , JPIXL+l , ISTEP 
RBUF(J) - TBUF(I) 

110 J = J+l 

READL - 0 
RETURN 
C 

C ERROR 
C 

999 READL - IERR 
END 
C 
C 

C WRITE WORK FILE SUBROUTINE 
C 

c 

INTEGER FUNCTION RITF.L(LINE, IPIXL, JPIXL, RBUF) 
C 

COMMON /C3LK/IDCB( 528), TBUF(512), IFLAG 
C 

DIMENSION RBUF( 5 12 ) 

O 

Sj 

C CHECK IF FILE OPENED 
C 

IF ( IFLAG .EQ. 1) GO TO 100 

r\ 

o 


•J i I J 




.100 i urii.M nu 


0116 

0117 

0118 

0119 

0120 
0121 
0122 

0123 

0124 

0125 

0126 

0127 

0128 
0129 
<v 

'^02 

0133 

0134 

0135 

0136 
O’. 37 

0138 

0139 

0140 

0141 

0142 

0143 

0144 

0145 

0146 

0147 

0148 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158 

0159 

0160 
0161 
0162 

0163 

0164 

0165 

0166 

0167 

0168 

0169 

0170 

0171 

0172 

0173 

0174 

0175 

0176 

0177 

0178 

0179 


C 

CALL OPEN( IDCB , IERR, 6HWF0000 ,2,0,0,528) 

IF (IERR .LT. 0) GO TO 999 
IFLAG - 1 
C 

C FILE OPENED--WRITE APPROPRIATE LINE 
C 

100 CALL READF(IDCB, IERR, TBUF, 1024, LEN,LINE+2) 
IF (IERR .LT. 0) GO TO 999 
C 

ISTEP - 1 

IF (IPIXL .GT. JPIXL) ISTEP - -1 
J ■ 1 

DO 110 I-IPIXL+1 , JPIXL+1 , ISTEP 
TBUF(I) - RBUF(J) 

110 J - J+l 
C 

CALL WRITF(IDCB, IERR, TBUF, O.LINE+2) 

IF (IERR -LT. 0) GO TO 999 
C 

RITEL - 0 
RETURN 
C 

C ERROR RETURN 
C 

999 RITEL - IERR 
END 
C 
C 

C BLOCK DATA SUBROGRAM 

C 

C 

BLOCK DATA 
C 

COMMON /CBLK/ IDCB ( 5 28 ) , TBUF ( 5 1 2 ) , IFLAG 
C 

DATA IFLAG/O/ 

C 

END 


C 

C 

C CLOSE WORK FILE SUBROUTINE 

C 

C 


SUBROUTINE CLSWF (NLINE , NPIXL , PMAX, PMIN) 

n 

Va. 

COMMON /CBLK/ IDCL(528) 

C 

DIMENSION IB(6) 

C 

EQUIVALENCE (IB2 ,IB(2) ) , ( 1 .B(3) ,RMAX) , (IB(5) ,RMIN) 


C 

C 

C THIS ROUTINE IS USED TO CLOSE THE WORK FILE 
C 

C WRITE DATA ON WORK FILE 
C 


IB - NLINE 
IB 2 - NPIXL 
RMAX - PMAX 
RMIN = PMIN 




CALL WRITF( IDCB, IERR, IB, 6,1) 
CALL CLOSE(IDCB) 
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&DINTF T-00004 IS ON CR00022 USING 00009 ELKS R-0087 


0001 

FTN4 

,Q,T,C 

0002 


PROGRAM DINTP 

0003 

C 


0004 

C 

THIS PROGRAM IS USED CHANGE THE PHYSICAL SIZE OF AN IMAGE 

0005 

C 


0006 

C 

WRITTEN BY WINSER E. ALEXANDER 

0007 

C 


0008 


DIMENSION AINT(1024) ,F(512) ,IPRAM(5) ,DIRC(515) ,INM( 2) 

0009 


EQUIVALENCE (F( 1 ) ,DIRC(4) ) , (DIRC( 1 ) , INM( 1 ) ) 

0010 


EQUIVALENCE (INM(l) ,NROW) , (INM(2) ,ICOLS) , (DIRC(2) ,AMAX) 

0011 


EQUIVALENCE (DIRC(3) ,AMIN) 

0012 

c 


0013 

c 

INPUT PARAMETERS (CALL RMPAR) 

0014 

c 

IPRAM(l)- LOGICAL UNIT FOR INTERACTIVE DEVICE 

0015 

U 

IPRAM(2) - NUMBER OF DESIRED ROWS IN OUTPUT IMAGE 

0016 

r 

I?RaM( 3 ) = NUMBER OF DESIRED COLUMNS IN OUTPUT IMAGE 

0017 



0018 

c 

L'.IKGZ TO BE USED IS ASSUMED TO BE IN IMAGE WORK FILE (WFOOOO 

0019 

c 


0020 


CALL RM PA R ( I PRAM ) 

0021 


L 7 >I?RAM(1) 

0022 


lE(LU.LS.O) LU=*l 

0023 


N:rEW=I?RAM(2) 

0024 


NC0LS=IPRAM(3) 

0025 


NCM1-NC0LS-1 

0026 


IMX-512 

0027 


IMXP1-IMX+1 

0028 

c 


0029 

c 

OBTAIN PARAMETERS FROM CURRENT IMAGE 

0030 

c 


0031 


IGET»READL(-1,0,511,DIRC) 

0032 


ICMl=ICOLS-l 

0033 


IF(IGET.LT.O) GO TO 999 

0034 

c 


0035 

c 

INTERPOLATE IMAGE 

0036 

c 


0037 


DY=FLOAT ( NRCW ) /FLOAT ( NNEW ) 

0038 


DX=FLOAT ( ICOLS ) /FLOAT (NCOLS) 

0039 


IFLT=0 

0040 


IF(DY.GT.l.O) STOP 111 

0041 


IF(DX.LT.O.O) IFLT=1 

«, 342 


IFR=0 

0043 


IFE=0 

0044 

c 



INITIALIZE ARRAYS 


0045 C 

0046 C 

004 7 IGET»READL( 0 , IFE , IC0LS-1 ,AINT(MXPi ) ) 

0048 IF(IGET.LT.O) GO TO 999 

0049 IGET"READL( 1 , IFE , ICMl , AINT( 1 ) ) 

0050 IF(IGET.LT.O) GO TO 999 

0051 C 

0052 MCNT*2 

0053 MORG-NROW 

0054 DO 100 KK«NNEW,1,-1 

0055 C 

0056 C COMPUTE Y 

0057 C 

0058 20 Y=(NNEW-KK)*DY-(NROW-MORG) 

0059 IF(Y.LT.l.O) GO TO 50 

0060 C 

0061 C BRING IN NEW BW 


0062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

0078 

0079 

0080 
0081 
0082 

0083 

0084 

0085 

0086 

0087 

0088 

0089 

0090 

0091 

0092 

0093 

0094 
C095 


C 

CALL MOVE (A INT , iCOLS , IMXPl ) 

C 

MCNT-MCNT+1 

IGET=0 

IF (MCNT . GT . NROW ) IGET=-150 
IF(IGET.LT.O) GO TO 999 
IGET=READL(MCNT , IFE , ICMl ,AINT) 

IF(IGET.LT.O) GO TO 999 
MORG-MORG-1 
C 

C RECOMPUTE Y 

C 

GO TO 20 
C 

C INTERPOLATE FOR NEW ROW 

C 

50 CALL INTRP (A INT , Y , DX , NCOLS , ICOLS , F ) 

C 

C OUTPUT CURRENT ROW 

C 

100 CALL RITEL(KK-1,0,NCM1,F) 

C 

C NOTE THAT WORK FILE IS NOT CLOSED BY THIS PROGRAM 
C 

C INSERT PARAMETERS IN WORK FILE 

C 

NROW=NNEW 

ICOLS=NCOLS 

CALL RITEL(-1 ,0,ICM1 ,DIRC) 

999 CONTINUE 
C 

C ERROR PROCESSING 

C 


0096 WRITE(LU, 1000) IGET 

0097 1000 FORMATC' ERROR CODE =» ”,115) 

0098 CALL EXEC(6) 

0099 END 

0100 C 
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0101 

0102 

0103 

0104 

0105 

0106 
0107 
0103 

0109 

0110 
0111 
0112 
0113 


C 

C 

C 

C 


SUBROUTINE MOVE(AINT,ICOLS,IMXPl) 

THIS SUBROUTINE MOVES ICOLS ELEMENTS IN ARRAY AINT FROM 
A START POINT OF 1 TO A START POINT OF IMXP1 

DIMENSION AINT(l) 

DO 10 I-l, ICOLS 
10 A INT( IMXP1+I ) - AINT(I) 

RETURN 

END 

END$ 


&WTAPE T-00004 IS ON CR00022 USING 00012 BLKS R=0127 


0001 FTN4,Q,C,T 

0002 

0003 

0004 

0005 


C 

C 

C 

C 

C 

C 

C 

c 

c 

c 


PROGRAM WTAPE 

THIS PROGRAM FROMS A PART OF THE IMAGE PROCESSING SYSTEM 
IT IS USED TO STORE AN IMAGE ON TAPE AND THEN PURGE FROM DIS 


0006 

0007 

0008 

0009 

0010 
0011 
0012 

0013 

0014 

0015 C 

0016 
0017 
0013 C 

0019 C 

0020 C 

0021 
0022 

0023 

0024 C 

0025 

0026 C 

0027 C POSITION TAPE 

0028 C 

WRITE(LU, 45) 

READ(LU, 46) IOPT 
IF (IOPT .NE. 2HG0) GO TO 1000 
WRITE(LU, 51) 

READ(LU,*) IFNUM 


THE IMAGE INVENTOPRY FILE IS UPDATED TO SHOW THA'Z THE IMAGE 
TAPE 

WRITTEN BY WINSER E. ALEXANDER 

DIMENSION IDCBl ( 2 72 ) , IDCB2 ( 528 ) , IMAGE ( 6 ) , IPRAM( 5 ) , JNAME( 3 ) 
DIMENSION IDATA ( 5 1 2 ) , I S IZE ( 2 ) , IRTN (5),IBUF(15) 

EQUIVALENCE (IBUF(12) ,ILOC) , (IBl’F( 13) , JNAME) , (IBUF(7) ,NLINE) 
EQUIVALENCE (IBUF(8) .NPIXL) , (IBUF(9) , IPMIN) , (IBUF( 10) , IPMAX) 

GET INPUT PARAMETERS 

CALL RMPAR(IPRAM) 

LU - IPRAM(l) 

IF(LU.LE.O) LU-1 

LU2 ■ 8 


0029 

0030 

0031 

0032 

0033 

0034 C 

0035 

0036 

0037 

0038 

0039 

0040 


C 

C 


SPACE TO FILE POSITION 

CALL EXEC( 3 , 400B+LU2 ) 

IF (IFNUM .LE. 0) GO TO 1000 
IF (IFNUM .EQ. 1) GO TO 5 
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0041 



DO 55 I»1 , IFNUM-l 

0042 



CALL EXEC( 3 , 1 300B+LU2 ) 

0043 

55 


CONTINUE 

0044 

C 



0045 

C 


GET IMAGE NAME FROM USER 

0046 

C 



0047 

C 



0048 

5 


WRITE(LU.IO) 

0049 


10 FORMAT ( " ENTER IMAGE NAME (12 CHARACTERS /E TO EXIT)?J ) 

0050 



READ (LU, 20) IMAGE 

0051 


20 FORMAT (6A 2) 

0052 



IF (IMAGE .EQ. 2H/E) GO TO 1001 

0053 

C 



0054 

C 


OPEN DIRECTORY FILE 

0055 

C 



0056 


30 

CALL OPEN( IDCB1 , IERR, 6HIMCIRC, 1 , 2HIM, 23 , 272) 

0057 



IF(IERR.LT.O) GO TO 999 

0058 

C 



0059 

C 


FIND IMAGE FILE 

0060 

C 



0061 


40 

CALL READF( IDCB1 , IERR, IBUF , 1 5 ,LEN) 

0062 



IF(LEN.NE.-l) GO TO 35 

0063 



WRITE(LU, 35) 

0064 

36 


FORMAT ("IMAGE NOT FOUND") 

0065 



GO TO 5 

0066 

35 


IF(IERR.LT.O) GO TO 999 

0067 

C 



0068 



IF( ICMPW( IMAGE, IBUF , 6) .NE .0) GO TO 40 

0069 

C 



0070 

C 


IMAGE FOUND 

0071 

C 



0072 

C 


CLOSE DIRECTORY FILE AND OPEN IMAGE FILE 

0073 

C 



0074 



CALL CLOSE(IDCBl) 

0075 

C 



0076 



CALL OPEN( IDCB2 , IERR, JNAME , l , 2HIM, 23, 528) 

0077 



IF(IERR.LT.O) GO TO 999 

0078 

C 



0079 

C 


CHECK FOR TAPE ON TRANSPORT 

0080 

C 



0081 

45 


FORMAT ( " PUT TAPE ON TRANSPORT & PUT TAPE UNIT ON LINE." 

0082 


i 

*/" ENTER -GO- WHEN READY"/) 

0083 


46 

CM 

3 

H 

O 

Ua 

0084 

c 



0085 

c 



0086 



WRITE(LU, 48) IPMAX.IPMIN 

0087 


48 

FORMAT ( ” MAXIMUM VALUE » ",1I8,". MINIMUM = ",1I8) 

0088 

c 



0089 

c 


IF(IPMAX.LE. 255) IMAGE WILL BE PACKED FOR OUTPUT (8 BIT IMAG 

0090 

c 



0091 



ITYPE - 15 

0092 



IF(IPMAX.LE. 255.AND.IPMIN.GE.0) ITYPE » 8 

0093 

c 



0094 

c 



0095 

51 


FORMAT ("FILE »??_") 

0096 

C 



0097 

C 






48 


0098 

C 



0099 

C ! 

OUTPUT DATA TO TAPE 

0100 

C 



0101 

60 


DO 80 I -1,512 

0102 



CALL FILL( IDATA, 0,512) 

0103 



I ERR -0 

0104 



IF (I .LE. NLINE) CALL READF(IDCB2 ,IERR, IDATA, 512) 

0105 



IF (IERR .LT. 0) CO TO 999 

0106 

C 



0107 



NOUT - 512 

0108 



IF (ITYPE .EQ. 15) GO TO 70 

0109 

C 



0110 

C 

PACK DATA 

0111 

C 



0112 



DO 65 J-1,512,2 

0113 



CALL R0T8( IDATA (J),ITEMP) 

0114 

6* 


IDATA(J) - I0R(ITEMP,IDATA(J+1)) 

0115 



NOUT - 256 

0116 

C 



0117 

C 

WRITE DATA 

0118 

C 



0119 

70 


CALL EXEC( 2 , LU2 , IDATA , NOUT ) 

0120 

80 


CONTINUE 

0121 

C 



0122 



CALL EXEC( 3 , 100B+LU2 ) 

0123 



CALL CL0SE(IDCB2) 

0124 



GO TO 5 

0125 

C 



0126 

C 


FILE ERROR 

0127 

C 



0123 


999 

WRITE(LU,996) IERR 

0129 


996 

FORMAT(" FILE ERROR - ”,114) 

0130 



CALL CLOSE(IDCBl) 

0131 



CALL CL0SE(IDCB2) 

0132 

1001 

CALL EXEC( 3 , 400B+LU2 ) 

0133 

C 



0134 

1000 

CONTINUE 

0135 



END 

0136 

C 



0137 

c 



0138 



SUBROUTINE FILL(IARAY,ICHAR,NUM) 

0139 

c 



0140 

c 


THIS SUBROUTINE IS USED TO FILL THE ARRAY " IARAY" 

0141 

c 


THE CHARACTER ”ICHAR“ 

0142 



DIMENSION IARAY(NUM) 

0143 

c 



0144 



DO 10 I-l.NUM 

0145 


10 

IARAY(I)-ICHAR 

0146 



RETURN 

0147 



END 

0148 



END$ 


WITH 
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0001 

0002 

0003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 
0011 
0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 
0021 
0022 

0023 

0024 
Ov25 
0026 

0027 

0028 

0029 

0030 

0031 

0032 

0033 

0034 

0035 

0036 

0037 

0038 

0039 

0040 

0041 

0042 

0043 

0044 

0045 

0046 

0047 

0048 

0049 

0050 

0051 

0052 

0053 

0054 

0055 

0056 

0057 

0058 

0059 

0060 
0061 
0062 


FTN4.L 

PROGRAM PLOTV 
DIMENSION LU(5) 

INTEGER IDCB(l44 ),BUFF( 4 ), NAME(3) 

DATA NAME / 2HDA , 2HTA , 2H 1 / 

C 

C GET LU 
C 

CALL RMPAR(LU) 

C 

CALL INITA(O) 

CALL OPEN(IDCB,IERR,NAME) 

IF (IERR .GE. 0) GO TO 20 
WRITE(LU, 10) IERR 
10 FORMAT ("OPEN ERROR", F5.0) 

STOP 

C20 CONTINUE 

20 CALL READF ( IDCB , IERR, BUFF » 4 , IERR) 

IF (IERR .GE. 0) GOTO 40 
WRITE(LU, 30) IERR 
30 FORMAT ("READ ERROR" ,F5.0) 

GO TO 55 
40 CONTINUE 

CALL DVECT(BUFF,BUFF(2),BUFF(3),BUFF(4),LU) 

50 GO TO 20 
55 STOP 
END 

SUBROUTINE DVECT(IX1,IY1,IX2,IY2,LU) 

DIMENSION IBUFF(5) 

C 

C DRAWS A VECTOR BETWEEN XI, Yl AND X2,Y2 
C 

SCAL -255./1024. 

IBUFF1 »(SCAL*IXl+0.5)+128 

IBUFF2 «(SCAL*IYl+0.5) 

IBUFF3 “(SCA«*IX2+0. 5)+128 

IBUFF4 »(SCAL*IY2+0. 5) 

IBUFF1 - IAND( IBUFF1 , 777B) 

IBUFF2 - IAND( IBUFF2 , 377B) 

IBUFF3 » IAND(IBUFF3,777B) 

IBUFF4 » IAND(IBUFF4, 377B) 

IBUFF(l) = IBUFF1 + 44000B 
IBUFF(2) » IBUFF2 + 64000B 
IBUFF(3) — IBUFF1 + IBUFF3 + 50000B + 512 
IBUFF(4) — IBUFF2 + IBUFF4 + 72000B + 256 
C 

CALL DRIVR( 2 , IBUFF , 4 ) 

C 

RETURN 

END 

SUBROUTINE INITA(IBACK) 

DIMENSION INIT(6) 

DATA INIT/30000B , 10037 7B , 10377B , 24021B , 26000B/ 
C 

C IBACK - 1 FOR REVERSE BACKGROUND 
C INITIALIZE 
C 

IF( IBACK .EQ. 1) INIT(4)=»24221B 
CALL DRIVR(2,INIT, 5) 

RETURN 

END 

$ 
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0001 

FTN4.L 

0002 



PROGRAM DPLAM 

0003 

C 



0004 

C 

THIS PROGRAM DISPLAYS THE FILTER CHARACTERISTICS 

0005 

c 



0006 

c 



0007 



C0MM0N/CNT/XM(30, 30) 

0008 



COMMON/WORK/WO( 130) 

0009 



C0MM0N/QDCAZ/IQ(40) 

0010 



INTEGER BUFF 

0011 



COMMON/ /IDCB( 144) ,BUFF( 10) 

0012 



DIMENSION IBUF(80) ,ILU(5) ,A(25),B(25) ,AA( 5 , 5) , BB( 5 , 5) 

0013 



DIMENSION XXX(3i) , YYY(31) ,XYP(3l , 2) ,LXY( 15, 3) ,AR(60) 

0014 



DIMENSION XERR(3l),CZ( 9) , IREG(2) ,U(3 , 3, 2) , V(3 , 3, 2) 

0015 



COMPLEX HA,HB,Z(25) 

0016 



EQUIVALENCE (AA( 1 , l) ,XM(l, 1) ) , (BB( 1 , l) ,XYP( 1,1)) 

0017 



EQUIVALENCE (IREG(l).REG) 

0018 



EQUIVALENCE (IBUF(i),U(l,l,l)),(IBUF{41),V(l,l,l)) 

0019 

c 



0020 



CALL RMPAR(ILU) 

0021 



LU-ILU'l) 

0022 



MN-ILU(2) 

0023 



A MAX - 0.0 

0024 



AMIN -1000.0 

0025 



MDIM - 30 

0026 



NDIM - 30 

0027 

c 



0023 

c 



0029 

c 

GET 

FILTER COEFF'S 

0030 



CALL EXEC( 14,1, IBUF ,80) 

0031 

c 



0032 



IF(MN.EQ. 3) GO TO 100 

0033 



MNL-9 

0034 



DO 10 J-1,3 

0035 



DO 10 K-1,3 

0036 



II-J+(K-1)*3 

0037 



A(II)-U( J,K, 1) 

0038 


LO 

B(II)-V(J,K,1) 

0039 



GO TO lOi. 

0040 


100 

DO 103 1-1,5 

0041 



DO 103 J-1,5 

0042 



AA(I,J)-0.0 

0043 


103 BB(I,J)-0.0 

0044 



DO 102 1-1,3 

0045 



DO 102 J-1,3 

0046 



DO 102 K-1,3 

0047 



DO 102 L-1,3 

0048 



IK-I+K-1 

0049 



JL-J+L-1 

0050 



AA( IK, JL)-AA( IK, JL)+U(I, J , l)*U(K,L,2) 

0051 


102 

BB(IK, JL)-BB(IK, JL)+V(I, J, 1)*V(K,L, 2) 

0052 



DO 11 J*1 , 5 

0053 



DO 11 K-1,5 

0054 



II-J+(K-1)*5 

0055 



A(II)-AA(J,K) 

0056 


11 

B(II)-BB(J,K) 

0057 



MNL-25 



0058 

101 

WRITE(LU.lOll) 

0059 

1011 

F0RMAT(21H COEFFICIENT MATRICES,/) 

0060 


MRITE(LU.IOS) (A(I), 1-1,25) 

0061 


WRITE(LU,105)(B(I), 1-1,25) 

0062 

105 

F0RMAT(5(1H ,5E10.2/)/) 

0063 

C 


0064 

C 

COMPUTE THE CENTER OF OUTPUT ARRAY 

0065 

C 


0066 


WRITE (LU, 12) 

0067 

12 

FORMATC ENTER MX FOR HORIZONTAL FREQUENCIES'*/) 

0068 


READ(LU, 13)MX 

0069 

13 

F0RMAT( 112) 

0070 


WRITE(LU, 14) 

0071 

14 

F0RMAT(" ENTER MY FOR VERTICAL FREQUENCIES”/) 

0072 


READ(LU, 13) MY 

0073 

203 

MXC-MX/2 

0074 


MXT-2*MXC 

0075 


NX-0 

0076 


IF(MXT.NE.MX) NX-1 

0077 


MYC-MY/2 

0078 


MYT-2*MYC 

0079 


NY-0 

0080 


IF(MYT.NE.MY) NY-1 

0081 


MXN-MXC+1 

0082 


MYN-MYC+1 

0083 

* 

WRITE(LU, 301) 

0084 

300 

FORMATC COMPUTE SQUARED MAGNITUDE "/) 

0085 

301 

FORMATC' INITIALIZE ARRAY”/) 

0086 

C 


0087 

C 

COMPUTE SQUARED MAGNITUDE CHARACTERISTIC 

0088 

C 


0089 


MX-MXT+NX 

0090 


MY-MYT+NY 

0091 


FCX-2 .0/FL0AT(MX) 

0092 


FCY-2.0/FL0AT(MY) 

0093 


IF(MX.LE. 101. AND. MY. LE. 61) GO TO 204 

0094 


IF(MX.LE.lOl) GO TO 202 

0095 


MX-101 

0096 


WRITE(LU, 200) 

0097 

200 

FORMATC' SIZE OF ARRAY WAS REDUCED TO 31 FOR HORIZONTAL 

0098 

202 

IF(MY.LE.61) GO TO 203 

0099 


MY-61 

0100 


WRITE(LU, 201) 

0101 


GO TO 203 

0102 

201 

FORMATC SIZE OF ARRAY WAS REDUCED TO 31 FOR VERTICAL ”/) 

0103 

204 

WRITE (LU, 300) 

0104 


DO 20 I-l.MX+l 

0105 


DO 20 J-l.MY+l 

0106 


XF=FCX*( I-MXC-l) 

0107 


XXX( I )=XF 

0108 


YF-FCY*( J-MYC-1) 

0109 


YYY( J)-YF 

0110 


CALL ZWC(Z,XF,YF,MN) 

0111 


HA-CMPLX(0. 0,0.0) 

0112 


HB-HA 

0113 


DO 21 K-l.MNL 

0114 


HA-HA+A(K)*Z(K) 

0115 


HB-HB+B(K)*Z(K) 
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i 




0116 

0117 

0118 

0119 

0120 
0121 
0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 

0132 
Oi.33 

0134 

0135 

0136 

0137 

0138 

0139 

0140 

0141 

0142 

0143 

0144 

0145 

0146 

0147 

0148 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158 

0159 

0160 
0161 

0162 

niAi 


21 CONTINUE 

XA-CABS(HA) 

X3-CABS(HB) 

IF(XB.LE.1.0E-20) XB-1.0E-20 
XA-XA/XB 

XM(I , J)»XA**2 

IF(XM(I, J) .LT.AMIN) AMIN-XM(I.J) 
IF(XM(I,J).GT.AMAX) AMAX-XM(l.J) 

20 CONTINUE 

WRITE(LU, 302 )AMAX, AMIN 

302 FORMATC AMAX - " , 1E10. 2 , 3X, "AMIN - ".IE10.2/) 
C 

C SQUARED MAGNITUDE NORMALIZED 

C 

C 

C OBTAIN W-l PLOT FROM ARRAY 

C 

DO 22 I-i.MXN 
XYP(I, 2)-XM(I+MXC,MYN) 

XERR(I)«XYP(I,2) 

22 XYP(I, l)»FCX*(I-i) 

WRITE(LU,306)(XYP(I,l),XYP(I,2),l-l,MXN) 

306 F0RMAT(///1H ,6( 1E10.2.3X)/) 

XL-0.0 

XU-l.O 

MC-2 

C 

C CALCULATE Z-W PLOT 

C 

X«(MXN)**2+(MYN)**2 
FCX-0.7071*FCX 
NUM-SQRT(X)+1 
DO 30 I-l.MXN 
XF-FCX*(I-1) 

CALL ZWC(Z,XF,XF,MN) 

HA-CMPLX(O.O.O.O) 

HB-HA 

DO 31 K-l.MNL 
HA-HA-+A(K)*Z(K) 

31 HB»HB+B(K)*Z(K) 

XA -CABS (HA) 

XB-CABS(HB) 

IF(XB.LE.1.0E-20)XB-l.0E-20 
XA-XA/XB 
vvp ( t 2)-XA**2 
30 XYP(I, 1)-XF*1.414 

WRITE(LU, 306) (XYP(I, 1) , XYP(I, 2) ,1-1 ,MXN) 
r 


COMPUTE ERROR FUNCTION 


0164 

0165 

0166 

0167 

0168 

0169 

0170 

0171 

0172 

0173 

0174 

0175 

0176 

0177 

0178 

0179 

0180 
0181 
0182 

0183 

0184 

0185 

0186 

0187 

0188 

0189 

0190 

0191 

0192 

0193 

0194 

0195 

0196 

0197 

0198 

0199 

0200 
0201 
0202 

0203 

0204 

0205 

0206 

0207 

0208 

0209 

0210 
0211 
0212 

0213 

0214 

0215 

0216 


C 

c 

ERR- 0.0 

00 350 J-i.MDIM 

350 ERR-ERR+((XERR(J)-XYP(J,2))/AMAX)**2 
WRITE(Ll), 360) ERR 

360 FORMAT (” RELATIVE ERROR - ”,IE15.7/) 

C COMPUTE CONTOURS 

C 

C 

C PLOT IMAGE OF TRANSFER FUNCTION 
C 

CALL CONTR( XXX , YYY , AMA X , AMIN , MX+l , MY+1 , LU ) 
C 

4443 STOP 
END 

SUBROUTINE ZMC(Z,XF,YF,MN) 

C 

C THIS SUBROUTINE COMPUTES COMPLEX 

C VALUES FOR Z**I*W**J FOR 

C ZW TRANSFORM AND PLACES RESULTS 

C IN ONE DIMENTIONaL ARRAY Z 

C XF-HORIZONTAL RELATIVE FREQUENCY 

C YF-VERTICAL Rr L TIVK FREQUENCY 

C 

COMPLEX Z(25),R,S 
IF(ABS(XF).EQ. 1.0 ) XF - 0.99 
IF(ABS(YF) .EQ. 1.0) YF - 0.99 
PI-3.1415926 
RX-COS(PI*XF) 

RY-SIN(PI*XF) 

SX-COS(PI*YF) 

SY-SIN(PI*YF) 

R-CMPLX(RX.RY) 

S-CMPLX(SX.SY) 

IF(MN.GE. 3) GO TO 20 
DO 10 J-1,3 
DO 10 K-1,3 
I-J+(K-1)*3 

10 Z(I)-S**(J-l)*R**(K-l) 

GO TO 22 

20 DO 21 J-1,5 

DO 21 K-1,5 
I-J+(K-1)*5 

21 Z(I)-S**( J-l)*R**(K-l) 

22 RETURN 
END 

BLOCK DATA WORK 
COMMON/WORK/WO (130) 

C0MMON/CNT/XM(900) 

C0MM0N/QDCAZ/IQ(40) 

END 


$ 
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0001 

FTN* 

,L 

0002 


SUP'-'OTINE CONTR(XXX,YYY,AMAX,AMIN,MX,MY,LU) 

0003 


C0MM0N/CNT/XM(30, 30) 

0004 


DIMENSION XXX(MX) ,YYY(MY) ,CZ(9) , ISIZE(2) 

0005 


INTEGER BCFF,NAME9(3) 

0006 


COMMON / /IDCB(144),BUFF(4) 

0007 


DATA NAME9/ 2HDA , 2HTA , 2H1 / 

0008 


WRITE(LU, 100) 

0009 

100 

FORMAT (” SELECT TYPE OF FILTER PLOT "/ 

0010 


1" 1. CONTOUR"/" 2. PERSPECTIVE"/) 

OOU 


RBAD(LU,*) IFLAG 

0012 

C 


0013 

C 

GENERATE CZ 

0014 

C 


0015 


CZ(1)— 1. 

0016 


DO 3 K-2,9 

0017 


CZ(K)-CZ(K-l)+.25 

0018 


3 CONTINUE 

0019 

C 


0020 

C CREATE A PLOT DATA FILE 

0021 

C 


0022 


ITYPE-3 

0023 


ISIZE(l)-96 

0024 


CALL PURGE ( IDCB , IERR , NAME 9 ) 

0025 


IF(IERR .LT. 0) WRITE(LU.lOl) IERR 

0026 


CALL CREAT{IDCB , IERR, NAME 9 , I SIZE , ITYPE) 

0027 


IF (IERR .GE. 0) GO TO 201 

0023 


WRITE(LU, 101) IERR 

0029 

101 

FORMAT ("CREATE ERROR", F5.0) 

0030 


STOP 

0031 

C 


0032 

C 

00 3-D PLOTS 

0033 

C 


0034 

201 

IF (IFLAG. EQ.l) GO TO 10 

0035 


IF (IFLAG. EQ. 2) GO TO 20 

0036 

20 

CONTINUE 

0037 


CALL SET3D( 1 . , -1 . , l . ,-l . ,AMAX, AMIN, 2,0, . 5, . 5) 

0038 


CALL PLT3D(XXX, YYY.XM, 30,MX,MY,LU) 

0039 


IF(IFLAG.EQ.2) GOTO 30 

0040 

C 


0041 

C 

DO ISOGRAMS 

0042 

c 


0043 

10 

CONTINUE 

0044 


DO 11 I-l.MX 

0045 


DO 11 J-l.MY 

0046 


XM(I,J)-XM(I,J)/AMAX 

0047 

11 

CONTINUE 

0048 


CALL SET2D(1.,-1. ,3,0,1.) 

0049 


CALL PLT2D( XXX , Y YY , XM , 30 , MX , MY , CZ , 9 , LU ) 

0050 

30 

CONTINUE 

0051 


CALL CLOSE(IDCB) 

0052 


RETURN 

0053 


END 


0054 

0055 

0056 

0057 

0058 

0059 

0060 
0061 
0062 

0063 

0064 

0065 

0066 

0067 

0068 
0C69 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

0078 

0079 

0080 
0081 
0082 

0083 

0084 

0085 

0086 

0087 

0088 

0089 

0090 

0091 

0092 

0093 

0094 

0095 

0096 

0097 

0098 

0099 

0100 
0101 
0102 

0103 

0104 

0105 

0106 

0107 

0108 

0109 

0110 


SUBROUTINE SBT2D(ALPMAX,ALPMIN,BETMAX,BETMIN, 10RCV.IALPCL.AL 
COMMON/ QDCAZ/ IXYXYB(4,4),XZ,AX,BX,YZ,AY,BV 
DATA XCNTR , YCNTR, EL/ 5 l 2 . , 5 l 2 . , 1000 . / 

XZ-XCNTR 

YZ-YCNTR 

IF(ALTOBL-l. >6,7,8 

6 ONTINUE 
ZlALP-ALTOBL*EL 
ELBET-EL 

GO TO 9 

7 CONTINUE 
EtALP-EL 
ELBET-EL 
GO TO 9 

8 CONTINUE 
ELALP-EL 
ELBET-EL/ALTOBL 

9 CONTINUE 

IF (IORGN.EQ.l) GO TO l 

IF (I0RGN.EQ.2) GO TO 2 

IF (IORGN.EQ.3) GO TO 3 

GO TO 4 

1 CONTINUE 

IF (IALPCL.EQ.l) GO TO 10 
BX-L. 

AY-0. 

AX* -EU LP / (A LPMAX-A LPMI N ) 

BY— ELBET/(BETMAX-BETMIN) 

XZ-XZ+. 5*ELALP 
YZ-YZ+. 5*ELBET 
GO TO 5 
10 CONTINUE 
AX-0. 

BY-O. 

BX--ELBET/ (BETMAX-3ETMIN) 

AY— EIALP/ (ALPMAX-ALPMIN) 

XZ-XZ+. 5*ELBET 
YZ-YZ+. 5*ELALP 
GO TO 5 

2 CONTINUE 

IF (IALPCL.EQ.l) GO TO 20 
AX-0. 

BY-O. 

AY-ELALP/ (ALPMAX-ALPMIN) 

BX— ELBET/ (BETMAX-BETMIN) 

XZ-XZ+. 5*ELBET 
YZ*YZ-.5*ELALP 
GO TO 5 
20 CONTINUE 
AY-0. 

BX-O. 

AX— ELALP/ (ALPMAX-ALPMIN) 

BY-ELBET/ (BETMAX-BETMIN) 

XZ-XZ+. 5*ELALP 
YZ-Y7.-. 5*ELBET 
GO TO 5 

3 CONTINUE 


0111 


IF (IALPCL.EQ.l) GO TO 30 

0112 


AY-0. 

0113 


BX-O. 

0114 


AX-ELALP/ (ALPMAX-ALPMIN) 

0115 


BY-ELBET/ (BETMAX-BETMIN) 

0116 


XZ-XZ-. 5*ELALP 

0117 


YZ-YZ-.5*ELBET 

0118 


GO TO 5 

0119 

30 

CONTINUE 

0120 


AX-O. 

0121 


BY-O. 

0122 


AY-ELALP/ (ALPMAX-ALPMIN) 

0123 


BX-ELBET/ (BETMAX-BETMIN) 

0124 


XZ-XZ- . 5*ELBET 

0125 


YZ-YZ-. 5*ELALP 

0126 


GO TO 5 

0127 

•4 

CONTINUE 

0128 


IF (IALPCL.EQ.l) GO TO 40 

0129 


AX-O. 

0130 


BY-O. 

0131 


AY— EIALP/ (ALPMAX-ALPMIN) 

0132 


BX-ELBET/ (BETMAX-BETMIN) 

0133 


XZ-XZ- . 5*ELBET 

0134 


YZ-YZ+. 5*EIALP 

0135 


GO TO 5 

0136 

40 

CONTINUE 

0137 


A Y-0. 

0138 


BX-O. 

0139 


AX-ELALP/ (ALPMAX-ALPMIN) 

0140 


BY— ELBET/ (BETMAX-BETMIN) 

0141 


XZ-XZ-. 5*ELALP 

0142 


YZ-YZ+. 5*ELBET 

0143 

5 

CONTINUE 

0144 


XZ-XZ -AX*ALPMIN-BX*BETMIN 

0145 


YZ=YZ-AY*ALPMIN-BY*BETMI M 

0146 


IXYXYE( 1 , 1 )-IFIX(XZ+AX*ALPMIN+BX*BETMIN) 

0147 


IXYXYB( 2 , l)=IFIX(YZ4AY*ALPMIN+BY*BETMIN) 

0148 


IXYXYB( 1 , 2)-IFIX(XZ-»AX*ALPMIN+BX*BETMAX) 

0149 


IXYXYB( 2 , 2)-IFIX(YZ+AY*ALPMIN+BY*BETMAX) 

0150 


IXYXYB( 1 , 3)-IFIX(XZ+AX*ALPMAX+BX*BETMAX) 

0151 


IXYXYB( 2 , 3)-IFIX( YZ+AY*ALPMAX+BY*BETMAX) 

0152 


IXYXYB( 1 , 4)-IFIX(XZ+AX*ALPMAX+BX*BETMIN) 

0153 


IXYXYB( 2, 4)-IFIX(YZ-+AY*ALPMAX+BY*BETMIN) 

0154 


IXYXYB( 3, 1)-IXYXYB( 1,2) 

0155 


IXYXYB( 4 , 1 ) -IXYXYB( 2 , 2 ) 

0156 


IXYXYB( 3,2) -IXYXYB ( 1,3) 

0157 


IXYXYB( 4 , 2)-IXYXYB( 2,3) 

0158 


IXYXYB(3, 3) -IXYXYB ( 1,4) 

0159 


IXYXYB(4 , 3)-IXYXYB( 2,4) 

0160 


IXYXYB( 3 . 4 ) -IXYXYB ( 1,1) 

0161 


IXYXYB (4, 4) -IXYXYB (2,1) 

0162 


RETURN 

0163 


END 


0164 C 

0165 C 

0166 C 

0167 

0168 

0169 

0170 

0171 

0172 

0173 

0174 

0175 

0176 

0177 

0178 

0179 

0180 
0181 
0182 

0183 

0184 

0185 

0186 

0187 

0188 

0189 

0190 

0191 

0192 

0193 

0194 

0195 

0196 

0197 

0198 

0199 

0200 
0201 
0202 

0203 

0204 

0205 

0206 

0207 

0208 

0209 

0210 
0211 
0212 

0213 

0214 


*************************************************** i*********** 


SUBROUTINE PLT2D(ALPHA , BETA , GAMMA , IDMN , IALPHA , JBET \ , C , NUMC 
1 ,IFILE,LU) 

COMMON/QDCAZ / IXYXYB( 4 , 4) , XZ , AX , BX , YZ , AY , BY 
DIMENSION ALPHA(1),BETA(1),GAMMA(IDMN,1),C(1) 

INTEGER BUFF(4),NAME9(3) 

COMMON IDCB(144) 

COMMON/WORK/ IXI Y ( 2 , 62 ) , JXJY( 2,62) 

DATA NAME 9 /2H DA, 2HTA.2H1 / 

CALL 0PEN(IDCB,IERR,NAME9) 

NOGRID-O 

IF(NUMC.LE.O) ''O TO l 
IF (IALPHA)2,1,3 

2 CONTINUE 
NOGRID-1 

3 CONTINUE 
IMAX«IABS( IALPHA) 

IMAXP2-IMAX+2 

IF (JBETA)4,1,5 

4 CONTINUE 
NOGRID-1 

5 CONTINUE 
JMAX-IABS(JBETA) 

IF (NOGRID. EQ.l) GO TO 6 
DO 7 K-1,4 

CALL FLBUF(IXYXYB( 1 ,K) ,IXYXYB( 2 ,K) , 

1 IXYXYB(3,K),IXYXYB(4,K),BUFF) 

CALL WRITF ( IDCB , IERR, BUFF , 4 ) 

7 CONTINUE 

6 CONTINUE 

DO 8 N-l.NUMC 
DO 9 1-1 ,IMAXP2 
IXIY(1,I)=0 
JXJY(l,I)-0 
9 CONTINUE 

DO 10 J-l.JMAX 
IF(J.EQ.l) GO TO 111 
DO 12 I-l.IMAX 

IF(GAMMA(I, J) .EQ.GAMMA(I, J-l) ) GO TO 13 

IF (GAMMA(I, J) .GE.C(N) .AND. C(N) .GE .GAMMA ( I, J-l) ) GO TO 14 
IF(GAMMA(I, J) .LE. C(N) .AND. C(N) .LE.GAMMA( I, J-l) ) GO TO 14 

13 CONTINUE 
JXJY( 1,1+1 )=0 
GO TO 12 

14 CONTINUE 

BETINT=BETA(J-l)+(BETA(J)-BETA(J-l))*(C(N)-GAMMA(I,J-i))/(GA 
1J)-GAMMA(I, J-l) ) 

ALP INT-ALPHA ( I ) 

IXR=IFIX( XZ+AX*ALPINT+BX*BETINT) 


58 


0215 


IYR-IFIX(YZ4AY*ALPINT+BY*BETINT) 

0216 


IF(JXJY(l,I).EQ.O) GO TO 15 

0217 


CALL FLBUF ( IXR , I YR , JXJY( 1 , I ) , JXJY( 2,1), BUFF ) 

0218 


CALL WRITF ( IDCB , I ERR , BUFF , 4 ) 

0219 

15 

CONTINUE 

0220 


IF(IXIY(l,I+l).EQ.O) GO TO 16 

0221 


CALL FLBUF ( IXR , I YR , IXI Y ( l , 1+1 ) , IXI Y ( 2 , 1+1 ) , BUFF ) 

0222 


CALL WRITF(IDC.3,IERR,BUFF,4) 

0223 

16 

CONTINUE 

0224 


IF ( IXI Y( l , 1+2 ) . EQ . 0) GO TO 17 

0225 


CALL FLBUF ( IXR , I YR , IXI Y( 1 , 1+2 ) , IXIY( 2 , 1+2 ) , BUFF ) 

0226 


CALL WRITF(IDCB,IERR,BUFF,4) 

0227 

17 

CONTINUE 

0223 


JXJY( 1,1+1) -IXR 

0229 


JXJY( 2, I+l)-IYR 

0230 

12 

CONTINUE 

0231 

111 

CONTINUE 

0232 


DO 18 I-2.IMAX 

0233 


IF(GAMMA(I,J) .EQ. GAMMA ( 1-1 , J)) GO TO 19 

0234 


IF (GAMMA(I,J).GE.C(N).AND.C(N).GE GAMMA(I-1, J)) GO TO 20 

0235 


IF (GAMMA(I, J).LE.C(N) .AND. C(N) .LE.GAMMA(I-l, J)) GO TO 20 

0236 

19 

CONTINUE 

0237 


IXIY(l,I+l)-0 

0238 


GO TO 18 

0239 

20 

CONTINUE 

0240 


ALPINT-ALPHA(I-1)+(ALPHA(I)-ALPHA( I-l) )*(C(N)-GAMMA(I-1 , J) )/ 

0241 

l( 1, J)-GAMMA(I-1 , J) ) 

0242 


BETINT-BETA(J) 

0243 


IXR-IFIX(XZ+AX*ALPINT+BX*BETINT ) 

0244 


I YR- IF IX ( YZ+AY*ALPI NT+BY *BF.TINT ) 

02': 5 


IF(JXJY(l,I).EQ.O) GO TO 21 

0246 


CALL FLBUF(IXR,IYR, JXJY( 1 , I ) , JXJY(2 ,1 ) , BUFF) 

0247 


CALL WRITF (IDCB, I ERR, BUFF, 4) 

0243 

21 

CONTINUE 

0249 


IF (IXIY(1,I+1).EQ. 0) GO TO 22 

0250 


CALL FLBUF( IXR , I YR , IXIY( 1 , 1+1 ) , IXIY( 2 , 1+1 ) , BUFF) 

0251 


CALL WRITF(IDCB, IERR.BUFF.4) 

0252 

22 

CONTINUE 

0253 


IF ( JXJY( 1 , 1+1 ) . EQ . 0) GO TO 23 

0254 


CALL FLBUF( IXR , I YR, JXJY( 1 , 1+1 ) , JXJY( 2 , I+l ) , BUFF) 

0255 


CALL WRITF(IDCB,IERR,BUFF,4) 

0256 

23 

CONTINUE 

0257 


IXIY( 1 ,I+1)=IXR 

0258 


IXIY( 2, I+1)=IYR 

0259 

18 

CONTINUE 

0260 

10 

CONTINUE 

0261 

8 

CONTINUE 

0262 

1 

CONTINUE 

0263 


RETURN 

0264 


END 
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0265 

0266 

0267 

0268 

0269 

0270 

0271 

0272 

0273 

0274 

0275 

0276 

0277 

0278 
02/9 
0280 
0281 
0282 

0283 

0284 

0285 

0286 

0287 

0288 

0289 

0290 

0291 

0292 

0293 

0294 

0295 

0296 

0297 

0298 

0299 

0300 

0301 

0302 

0303 

0304 

0305 

0306 

0307 

0308 

0309 

0310 

0311 
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*************************************************************** 


SUBROUTINE SET3D(ALPMAX, ALPMIN, BETMAX, BETMIN, GAMMAX,GAMMIN , 
ORGN , IALPCL , GAMFAC, ALPFAC) 

LOMMON/QDCAZ /IXYXYB( 4 , 5) , XE , AX, BX, YZ , AY , BY , CY 
DATA ELX.ELY, EXLEFT, YBOTM '1012. ,856. , 12. , 156. / 
AX-ALPFAC*ELX/ (A LPMAX- ,1 X) 

AY-ALPFAC*(1.-GAMFAC)*m ’ / 1LPMAX-ALPMIN) 
BX-(1.-ALPFAC)*ELX/ (BE: . * -3ETMIN) 

BY»( 1. -ALPFAC)*(1 . -GAMFAC) *ELY/ (BETMAX-RETMIN) 

CY -GAMFAC* ELY/ (GAMMAX-GAMMIN) 

YZ“ -CY*GAMMIN+YBOTOM 
XZ -EXLEFT 

IF(IORGN.EQ.i)GO TO 1 
IF( IORGN .EQ. 2)G0 TO 2 
IF(IORGN.EQ. 3)G0 TO 3 
GO TO 4 

1 CONTINUE 
XZ-XZ+ELX 
AX— AX 
BX— BX 

IF ( IALPCL .EQ . 1 ) GO TO 10 
YZ«YZ+BY*(BETMAX-BETMIN) 

BY— BY 

ALPVRT-ALPMAX 
BETVRT-BETMIN 
GO TO 5 
10 CONTINUE 

YZ-YZ+AY*(ALPMAX-ALPMIN) 

AY— AY 

A LPVRT-ALPMIN 
BETVRT-BETMAX 
GO TO 5 

2 CONTINUE 
ALPVRT-ALPMAX 
BETVRT-BETMAX 

IF( IALPCL. SQ. 1)G0 TO 20 
XZ-XZ+BX*(BETMAX-BETMIN) 

BX— BX 
GO TO 5 
20 CONTINUE 

XZ-XZ+AX* (ALPMAX-ALPMIN) 

AX— AX 
GO TO 5 
3 CONTINUE 


0312 

0313 

0314 

0315 

0316 

0317 

0318 

0319 

0320 

0321 

0322 

0323 

0324 

0325 

0326 

0327 
0323 

0329 

0330 

0331 

0332 

0333 

0334 

0335 

0336 

0337 
0333 

0339 

0340 

0341 

0342 

0343 

0344 

0345 

0346 

0347 
0343 

0349 

0350 

0351 

0352 

0353 

0354 

0355 

0356 

0357 
0353 

0359 

0360 

0361 

0362 


IF(IALPCL.EQ.l)GO TO 30 
YZ“YZ+AY*(ALPMAX-ALPMIN) 

AY— AY 

ALPVRT-ALPMIN 
BETVRT-BETMAX 
GO TO 5 
30 CONTINUE 

YZ»YZ+BY*(BETMAX-BEaMIN) 

BY— BY 

ALPVRT-ALPMAX 
BETVRT-BETMIN 
GO TO 5 

4 CONTINUE 

YZ*YZ+ELY*(l . -GAMFAC) 

ALPVRT'«ALPMIN 
3STVRT-BETMIN 
AY— AY 
BY— BY 

IF(IALPCL.EQ.1)G0 TO 40 
XZ«XZ+AX*(ALPMAX-ALPMIN) 

AX— AX 
CO TO 5 
40 CONTINUE 

XZ -XZ+BX* ( BETMAX-BETMIN) 

CX— BX 

5 CONTINUE 

XZ=»XZ-BX*BETMIN-AX*ALPMIN 

YZ=YZ-BY*BETMIN-AY*ALPMIN 

IXYXYB( 1 , l)=XZ+AX*ALPMIN+BX*BETMIN 

IXYXYB( 2 , 1 )-YZ+AY*ALPMIN+BY*BETMIN+CY*GAMMIN 

IXYXYB( 3 , 1 )-XZ+AX*ALPMAX+BX*BETMIN 

IXYXYB( 4 , 1 )»YZ+AY*ALPMAX+BY*BETMIN+CY*GAMMIN 

IXYXYB(1,2)°IXYXYB(3,1) 

IXYXYB(2,2)-IXYXYB(4,1) 

IXYXYB( 3,2) -XZ+AX*ALPMAX+BX*BETMAX 
IXYXYB(4 , 2)-YZ4AY*ALPMAX+BY*BETMAX+CY*GAMMIN 
IXYXYB( 1 , 3)“IXYXYB(3, 2) 

IXYXYB( 2 , 3)=*IXYXYB(4,2) 

IXYXYB( 3 , 3)=XZ+AX*ALPMIN+BX*BETMAX 

IXYXYB( 4 , 3)=YZ4AY*ALPMIN+BY*BETMAX+CY*GAMMIN 

IXYXYB(1,4)=IXYXYB(3,3) 

IXYXYB(2,4)=IXYXYB(4,3) 

IXYXYB( 3 ,4)=IXYXYB( 1,1) 

IXYXYB(4, 4)=IXYXYB(2, l) 

IXYXYB( 1 , 5)=XZ+AX*ALPVRT+BX*BETVRT 

IXYXYB( 2 , 5 ) =YZ+AY*ALPVRT+BY*BETVRT+CY*GAMMIN 

IXYXYB( 3 , 5)“IXYXYB( 1 , 5) 

IXYXYB(4 , 5) a YZ+AY*ALPVRT+BY*BETVRT+CY*GAMMAX 
45 FORMAT (5(7X,I7)) 

RETURN 

END 


0363 

C 

*********6***************************************************** 

0364 

c 



0365 

c 



0366 

c 



0367 



SUBROUTINE PLT 3D (ALPHA , BETA , GAMMA , IDMN , IALPHA , JBETA , IFILE,L 

0368 



DIMENSION ALPHA (1 ) ,BETA( l) ,GAMMA( IDMN, 1) 

0369 



COMMON/WORK/LAS m( 2 , 200) 

0370 



COMMON/QDCA- / IXYXYB ( 4 , 5 ) , XZ , AX , BX , YZ , AY , BY , CY 

0371 



INTEGER BUFF(4) 

0372 



COMMON IDCB(144) 

0373 



NOGRID-O 

0374 



IF( IALPHA) 1,2, 3 

0375 


1 

CONTINUE 

0376 



NOGRID-1 

0377 


3 

CONTINUE 

0373 



IMAX-IABS ( IALPHA ) 

or r 



IF(JBETA)4,2,5 

0380 


4 

CONTINUF 

0381 



NOGRID-1 

0382 


5 

CONTINUE 

0383 



JMAX-IABS(JBETA) 

0384 



IF ( NOGRID. EQ.l)GO TO 6 

0385 

67 


FORMAT (5(7X,I7 ) ) 

0386 

68 


FORMAT (10X, "GOOD" ,15) 

0387 



DO 7 K-1,5 

0388 



CALL FLBUF( IXYXYB(1,K),IXYXYB(2,K), 

0389 


1 IXYXYB( 3 , K) , IXYXYB ( 4 , K) , BUFF ) 

0390 



CALL WRITF(IDCB, IERR,BUFF,4) 

0391 


7 

CONTINUE 

0392 


6 

CONTINUE 

0393 



DO 8 J-l.JMAX 

0394 



DO 8 I-l ,IMAX 

0395 



IXR-IFIX(XZ+AX*ALPHA( I )+BX*BETA( J) ) 

0396 



IYR-IFIX(YZ-W1Y*A:PHA(I)+BY*BETA(J)+CY*GAMMA(I,J)) 

0397 



IF(I.EQ.l)GO TO 9 

0398 



CALL FLBUF( IXR , IYR, LASTXY( 1,1-1) ,LASTXY( 2,1-1), BUFF) 

0399 



CALL WRITF(IDCB,IERR,BUFF,4) 

0400 


9 

CONTINUE 

0401 



IF(J.EQ. l)GO TO 10 

0402 



CALL FLBUF( IXR , IYR, LASTXY( 1,1) ,LASTXY( 2,1), BUFF) 

0403 



CALL WRITF ( IDCB , IERR , BUFF , 4 ) 

0404 


10 

CONTINUE 

0405 



LASTXY( 1,I)-IXR 

0406 



LASTXY(2,I)-IYR 

0407 


8 

CONTINUE 

0408 


2 

CONTINUE 

0409 



RETURN 

0410 



END 

0411 



SUBROUTINE FLBUF(IX1 ,IY1 ,1X2, IY2 ,BUFF) 

0412 



INTEGER BUFF(4) 

0413 



BUFF(l) = 1X1 

0414 



BUFF(2) - IY1 

0415 



BUFF(3) - 1X2 

0416 



BUFF(4) = IY2 

0417 



RETURN 

0418 



END 
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0001 

0002 

0003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 
0011 
0012 

0013 

0014 

0015 

0016 
0017 
0013 

0019 

0020 
0021 
0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

0030 

0031 

0032 

0033 

0034 

0035 

0036 

0037 

0038 

0039 

0040 

0041 

0042 

0043 

0044 

0045 

0046 

0047 

0048 

0049 

0050 

0051 

0052 

0053 

0054 

0055 


FTN4.L 

PROGRAM FDIGN 
C 

C THIS PROGRAM SCHEDULE FILTER DESIGN, STABILITY , AND DISPLAY 
C 

COMMON/WORK/WO (75) 

DIMENSION NAME1<3) ,NAME2(3) ,NAME3(3) ,IRTN(5) 

DIMENSION IDCB( 144) ,NAME4(3) ,NAME5(3) 

DIMENSION U(3,3,2),V(3,3,2),ILU(5),IBUF(80),I8UF2(80) 
EQUIVALENCE ( ILU( 1 ) , LU ) , ( IBUF , IBUF2 ) 

EQUIVALENCE (IBUF( 1) ,U( 1 , i , 1) ) , (IBUF(41) , V(l, 1,1)) 

DATA NAME 1 / 2H ST , 2HAB , 2H I / 

DATA NAME2 / 2HDP , 2HLA , 2HM / 

DATA NAME 3/ 2HC0 , 2HEF , 2HFS/ 

DATA NAME4/2HFI , 2HR0 , 2H / 

DATA NAME5/2HPL,2HOT,2HV / 

OATA V/18*0./ 

DATA U/18*0./ 

DATA IBUF/80*0/ 

C 

C GET LU 

CALL RMPAR(ILU) 

C 

C GET FILTER PARAMETERS 
C 

MN-1 

4 WRITE(LU, 400) 

400 F0RMAT( " SELECT FILTER DESIGN"/” 1. LOWPASS"/" 2. BANPPA 

1 3. HIGHPASS"/ " 4. BOOST FILTER"/” 5. TDLPF (LOWPASS)" 

2” 6. ROTATING FILTER "/" 7. NON-RECURSIVE FILTERS " ) 

READ(LU,401) IFIL 
IF(IFIL.EQ.4) GO TO 500 
IF(IFIL.EQ.3)G0 TO 410 
IF(TFIL.EQ.6) GO TO ''08 
IF( IFIL .EQ. 7) GO TO 1102 
WRITE(LU,402) 

402 FORMATf ENTER RELATIVE CUTOFF FREQUENCY FOR LOWPASS"/) 
READ(LU,403)F2 

403 FORMAT(F2.2) 

IF(IFIL.NE.2) GO TO 407 
WRITE(LU,404) 

404 FORMAT( " ENTER RELATIVE CUTOFF FREQUENCY FOR HIGHPASS"/) 
READ(LU,403) FI 

407 WRITE(LU,405) 

405 FORMAT ( " ENTER NUMBER OF FILTER STAGES”/) 

READ(LU,401 ) MN 

IBUF(40) -MN 

401 FORMAT(lIl) 

GO TO 411 

500 WRITE(LU, 510) 

510 FORMAT ( ” SELECT OPTION"/,” 1. LOW BOOST FILTER"/," 2. HI 
*ST FILTER"/) 

PEAD(LU, 515) IOPT 
515 FORMAT(ill) 

IF ( IOPT . GE . 0 . AND . IOPT . LE . 2 ) GO TO 530 
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0056 

0057 

0058 

0059 

0060 
0061 
0062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

0078 

0079 

0080 
0081 
0082 

0083 

0084 

0085 

0086 

0087 

0088 

0089 

0090 

0091 

0092 

0093 

0094 

0091 

0092 

0093 

0094 

0095 

0096 

0097 

0098 

0099 

0100 
0101 
0102 

0103 

0104 

0105 

0106 

0107 

0108 

0109 

0110 


WRITE(LU,520) 

520 FORMAT (” INVALID RESPONSE"/) 

GO TO 500 
C 

530 WRITE(LU,535) 

535 FORMATC" ENTER BOOST MAGNITUDE"/) 

READ(LU,*) BF 
WRITE (LU, 540) 

540 FORMAT(" ENTER RELATIVE BREAK FREQUENCY"/) 

READ(LU,403) FI 

IF(IOPT.EQ.O.OR.IOPT.EQ.l) WRITE(LU, 545) BF,Fl 
545 FORMATC* BOOST MAGNITUDE - ",1E15.5,” FREQUENCY - ",1F10.5," 
*OWBOOST FILTER."/," IS THIS CORRECT?"/) 

IF(I0PT.EQ.2) WRITE(LU, 550) BF,F1 

550 FORMATC" BOOST MAGNITUDE - ",1E15.5," BREAK FREQUENCY - ",1F 
* FOR HIGH BOOST FILTER.**/," IS THIS CORRECT**/) 

READ(LU, 551) IRES 

551 FORMATC 1A l ) 

IFCIRES.EQ.1HY.0R. IRES.EQ. lHy ) GO TO 552 
GO TO 520 

552 BF-SQRTCABSCBF)) 

IFCI0PT.EQ.2) GO TO 560 
ALP-1.0 

BET-BF-1.0 
GO TO 412 
560 ALP-BF 

BET-1. O-BF 
CO TO 412 

410 WRITE(LU,404) 

READ(LU,403) FI 

412 WRITECLU.405) 

READCLU.401) MN 

411 MN-MN+1 

408 IFCIFIL.EQ.l) CALL LPFLT(U, V, F2 ,MN,LU) 

IF( IFIL.EQ. 2) CALL BPFLTCU, V,Fl ,F2 ,MN,LU) 

IFC IFIL.EQ. 3) CALL BSTFT(U,V,F1 ,MN, 1.0,-1.0,LU) 
IF(IFIL.EQ.4) CALL BSTFTCU,V,F1 ,MN,ALP,BET,LU) 

IF(IFIL.EQ.5) CALL TDLPFCU, V,MN,F2,2,LU) 

IL.E CALL BPFLT(U, V,F1,F2,MN,LU) 

IFC IFIL.EQ. 3) CALL BSTFTCU, V,F1 ,MN, 1.0,-1.0,LU) 

IF( IFIL.EQ. 4) CALL BSTFT(U,V,F1 ,MN,ALP,BET,LU) 

IFCIFIL.EQ.5) CALL TDLPFCU, V,MN, F2 , 2 ,LU) 

IL.E IFCIFIL.EQ.6) CALL ROTAECU, V,MN,LU) 

C IFCIFIL .EQ. 7) CALL FIRCU.MN, WR, LU) 

CONTINUE 
Il.tJC 2) - MN 

IFC IFIL.EQ. 2) ILUC2) -MN + 1 
IFCIFIL.EQ.6) ILU(2)-MN-1 
C 

C SCHEDULE STABILITY TEST-STABT 
C 

CALL EXEC(23,NAME1 ,LU, ILU( 2) , 0, 0, 0, IBUF,80) 

C 

C 

C SCHEDULE DISPLAY PROGRAM-DP LAY 
IFCIFIL. EQ. 3) ILUC2) -MN + 1 
IFCIFIL. EQ. 4) ILUC2) -MN+1 
CALL EXECC23.NAME2 ,LU, ILUC 2) , 0,0,0,IBUF2 ,80) 

C 
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0111 

0112 

0113 

0114 

0115 

0116 

0117 

0118 

0119 

0120 
0121 
0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 

0132 

0133 

0134 

0135 

0136 

0137 

0138 

0139 

0140 

0141 

0142 

0143 

0144 

0145 

0146 

0147 

0148 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158 

0159 

0160 
0161 
0162 


IF(IFIL .EQ. 3) IBUF(4Q) -MN 
IF(IFIL .EQ. 4) IBUF(40) -MN 
IF(IFIL .EQ. 6) IBUF(40)-MN-i 
C 

GVLL PURGE(IDCB,IERR,NAME3,2HES) 

IF ( IERR .LT. 0) WRITE(LU.llOl) IERR 
CALL CREAT(IDCB,IERR,NAME3,2,3,2HES) 

IF (IERR .LT. 0) WRITE(LU, 1101) IERR 

1101 F0RMAT( "CREATE ERROR** ,F5.0) 

CALL WRITF(IDCB, IERR, IBUF,80) 

IF (IERR .LT. 0) WRITE(LO.llOl) IERR 
CALL CLOSE( IDCB , IERR) 

WRITE(LU, 1105) 

1105 FORMATC* ENTER DISPLAY DEVICE "//" 1. TV**/** 2. HP2648A'*) 

READ(LU,*) IDEV 

C 

IF (IDEV .EQ. 2) GO TO 1106 
CALL EXEC(23, NAMES, LU, 0,0, 0,0) 

GO TO 1107 

1106 CONTINUE 

CALL HP48A(LU) 

1107 CONTINUE 
GVLL EXEC(6) 

C 

C SCHEDULE NON-RECURSIVE FILTERS 

1102 CONTINUE 

CALL EXEC(23,NAME4,LU,0,0,0,0) 

STOP 

END 

SUBROUTINE BPFLT(U,V,F1,F2,N,LU) 

C 

C WRITTEN BY W. E. ALEXANDER 

C 

C FI BREAK FREQUENCY FOR LOW FREQUENCY CUTOFF 

C F2 BREAK FREQUENCY FOR HIGH FREQUENCY CUTOFF 

C 

C SUBROUTINE DESIGNS BANDPASS FILTER FROM LPFLT AND HPFLT 
C 

DIMENSION U(3,3,2),V(3,3,2),AA(3,3,2),BB(3,3,2) 

IF(F1. LT. 0.001. OR. FI. GT. 0.999) RETURN 
IF(F2. LT. 0.001. OR. F2.GT. 0.999) RETURN 
C 

FC=AMAXi(Fi ,F2) 

CALL LPFLT(AA,BB,FC,N,LU) 

C 

DO 20 1-1,3 
DO 20 J-1,3 
U ( I , J , l ) -AA ( I , J , 1 ) 

20 V ( I , J , 1 ) -BB( I , J , 1 ) 

C 

FC*AMIN1(F1 ,F2) 

CALL BSTFT(AA,BB,FC,N,i.0,-1.0,LU) 


0163 

c 


0164 


DO 21 1-1,3 

0165 


DO 21 J-1,3 

0166 


U(I,J,2)-AA(I,J,1) 

0167 

21 

V(1,J,2)-BB(I,J,1) 

0168 

c 


0169 

0170 


RETURN 

0171 


END 

0172 


SUBROUTINE BSTFT ( U , V , FC , N , ALP , BET , LU ) 

0173 

c 

FREQUENCY BOOST DESIGN ROUTINE 

0174 

C 

FC-RC*S/PI WHERE RC IS THE CUTOFF FREQUENCY IN RADIANS AND 

0175 

C 

S IS THE SAMPLING INTERVAL. THUS FC-0.5 GIVES A CUTO 

0176 

C 

FREQUENCY AT ONE FOURTH SAMPLING FREQUENCY. 

0177 

C 


0178 

C 

FOR HIGH PASS FILTER, LET ALP-1.0 AND BET— 1.0 

0179 

C 

FOR HIGH FREQUENCY BOOST FILTER, ALP-BF AND BET— 1.0*<BF-1 .0 

0180 

C 

WHERE BF-SQRT( DESIRED FILTER GAIN AT ONF. HALF SAMPLING 

0181 

C 

FOR LOW FREQUENCY BOOST FILTER, ALP-1.0 AND BET-(BF-l.O) 

0182 

c 


0183 

c 


0184 


DIMENSION U(3,3,2),V(3,3,2) 

0185 

c 


0186 


DO 21 K-1,2 

0187 


DO 21 1-1,3 

0188 


DO 21 J-1,3 

0189 


U(l, J,K)-0.0 

0190 

21 

V(I,J,K)-0.0 

0191 


WRITE(LU, 14) FC 

0192 

14 

FORMAT ( 1H0, " FC - ",1E22.5," FOR BOOST FILTER"/) 

0193 


PI-3.141592654 

0194 


D-1.0E-10 

0195 


PWR-0.25 

0196 


IF (N.EQ.3) PWR-0.125 

0197 


EPS-2. 0**PWR-1.0 

0198 


IF(N.EQ. 2. AND.BET.LT. 0.0) EPS-1.50702 

0199 


IF(N.EQ. 3. AND.BET.LT. 0.0) EPS-2. 4711 

0200 


XP-PI*FC*0. 5 

0201 


T-(SIN(XP)/C0S(XP))**2.0 

0202 


IF(T.GT.D) GO TO 10 

0203 


AAA-EPS/D 

0204 


GO TO 11 

0205 

10 

AAA-EPS/T 

0206 

11 

SALP-SQRT(AAA) 

0207 


DEM-t . 0-2 . 0*AAA 

0208 


IF(DEM.LT.D) GO TO 12 

0209 

13 

Pl-(+2 . 0*AAA-2 . 0*SQRT(2. 0)*SALP+1 . 0) /DEM 

0210 


GO TO 20 

0211 

12 

F— 1.0*DEM 

0212 


IF(F.GT.D) GO TO 13 

0213 


Pl-0.0 

0214 

C 


0215 

20 

A-((i.0+Pl)**2)/4.0 

0216 


AS-A**2 

0217 


P0S=P1**2 

0218 


R-4.0*(P0S'\S)+((1.0+P0S)**2-4.0*AS)-4.0*(P1*(1.C4P0S)-2.0*A 

0219 


IF(ABS(R) . LT.D) R-SIGN(D,R) 

0220 

* 

S-( (1.0-Pl )**4)/R 

0771 

r 






0222 

0223 

0224 

0225 

0226 

0227 

0228 

0229 

0230 

0231 

0232 

0233 

0234 

0235 

0236 

0237 

0238 

0239 

0240 

0241 

0242 

0243 

0244 

0245 

0246 

0247 
0243 

0249 

0250 

0251 

0252 

0253 

0254 

0255 

0256 

0257 

0258 

0259 

0260 
0261 
0262 

0263 

0264 

0265 

0266 

0267 

0268 

0269 

0270 

0271 

0272 

0273 

0274 

0275 

0276 

0277 

0278 

0279 

0280 
0281 


U( 1 , 1 , 1)-S*(ALP*P0S+BST*AS) 

U ( 1 , 2 , l ) -S* <ALP*P 1 * ( 1 . O+POS )+2 . 0*BET*AS) 

U(2,i,l)-U(l,2,l) 

U( 2 , 2 , 1 )-S*(ALP*( 1 . O+POS) **2+4 . 0*BET*AS) 

U( 1 , 3 , 1 )-S*(ALP*POS+BET*AS) 

U(3,l,l)-U(l,3,l) 

U(2,3,1)-S*(ALP*P1*(1.0+POS)+2.0*BET*AS) 

U(3,2,1)-U<2,3,1) 

U ( 3 , 3 , 1 ) -S* (ALP*POS+BET*AS) 

C 

V(i,l,l)-1.0 

V(l,2,l)«2.0*Pl 

V(2,l,l)-V(l,2,l) 

V(2,2,l)-4.0*POS 

V(l,3,l)-P0S 

V(3,l,l)-V(l,3,l) 

V(2,3,l)-2.0*P1*P0S 

V(3,2,l)-V(2,3,i) 

V(3,3,l)-POS**2 

C 

IF(N.EQ. 2) GO TO 27 
DO 26 1-1,3 
DO 26 J-1,3 
U(I,J,2)«U(I,J,1) 

26 V(I,J,2)-V(I,J,1) 

27 N - N-l 

RETURN 
END 

SUBROUTINE LPFLT(U, V ,FC ,N,LU) 

C LOW PASS RECURSIVE FILTER DESIGN ROUTINE 

C FC//RC*S/PI WHERE RC IS THE CUTOFF FREQUENCY IN RADIANS AND 
C S IS THE SAMPLING INTERVAL. THUS FCl'/O.S GIVES A CUTO 

C FREQUENCY AT ONE FOURTH SAMPLING FREQUENCY. 

C 

DIMENSION U(3,3,2),V(3,3,2) 

COMMON/ WORK/A (5, 5), 8(5,5) 

C 

DO 21 K-1,2 
DO 21 1-1,3 
DO 21 J-1,3 
U(I, J,K)-O.Q 
21 V(I, J,K)-0.0 

IF(FC.GE.0.99) FC-0.99 
WRITE(LU, 14)FC 

14 F0RI-IAT(1H0," FC - ",1E10.4," FOR LOWPASS FILTER ,/) 
PI-3.141592654 
D-1.0E-10 
PWR-0.25 

IF (N.EQ.3) PWR-0.125 
EPS-2. 0**PWR-1.0 
XP-PI*FC*0. 5 

T-(SIN(XP)/C0S(XP))**2 .0 
IF(T.GT.D) GO TO 10 
ALP-EPS/D 
GO TO 11 

10 ALP-EPS/T 

11 SALP-SQRT(ALP) 

DEM-1 . 0-2 . 0*ALP 
IF(DEM.LT.D) GO TO 12 

13 Pl-(+2 . 0*ALP-2 . 0*SQRT( 2 .0) *SALP+1 .0) /DEM 


0282 

0283 

0284 

0285 

0286 

0287 

0288 

0289 

0290 

0291 

0292 

0293 

0294 

0295 

0296 

0297 

0298 

0299 C 

0300 

0301 

0302 

0303 

0304 C 

0305 

0306 

0307 

0308 

0309 

0310 

0311 

0312 

0313 

0314 

0315 

0316 

0317 

0:13 

0319 

0320 

0321 

0322 

0323 

0324 

0325 

0326 

0327 

0328 

0329 

0330 

0331 

0332 

0333 

0334 

0335 

0336 

0337 

0338 


P2-P1 

IF(FC.CT.0.3)CO TO 20 
P2-(SQRT(T)-EPS)/(SQRT(T)+EPS) 

CO TO 20 

12 ?— 1.0*DEM 

IF(F.GT.D) GO TO 13 

Pl-0.0 

P2-0.0 

20 V(l,l,l)-1.0 
V( 1 ,2, l)«Pi+P2 
V(2,i,l)«V(i,2,l) 

V(1,3,1)-P1*P2 

V(3,l,i)-V(l,3,l) 

V(2,2,l)«V(i,2,l)**2 

V( 2 , 3, 1 )-Pl*P2**2+P2*Pi**2 

V(3,2,l)-V(2,3,i) 

V(3,3.i)-V(l,3,l)**2 

SUM-0.0 
DO 25 1-1,3 
DO 25 J-1,3 

25 SUM-SUM+V(I, J, 1) 

U( 1 , 1 , i)-SUM/16 .0 
U(i,3,l)-U(l,i,l) 
U(3,l,l)-U(l,l,l) 
U(3,3,l)«U(l,l,l) 

U(l,2,l)-SUM/8.0 

U(2,l,i)-U(l,2,l) 

U(2,3,l)-U(l,2,l) 

U(3, 2 , 1)-U(1, 2, l) 

U(2,2, l)-SUM/4.0 
IF(N.EQ.2) GO TO 1 
DO 26 1-1,3 
DO 26 J-l , 3 
U(I,J,2)«U(I,J,1) 

26 V(I,J,2)-V(I,J,l) 

GO TO 2 

1 U( 1 , 1 , 2)-l .0 
V(i,i,2)-1.0 

2 DO 30 1-1,5 
DO 30 J-l, 5 
A(I,J)-0.0 

30 B(I,J)-0.0 
DO 31 1-1,5 
DO 31 J-l, 5 
DO 31 K-1,3 
DO 31 L-1,3 
IK-I-K+1 
JL-J-L+l 

IF( IK.LE.O.OR. IK.GT. 3)G0 TO 31 
IF(JL.LE.0.0R.JL.GT.3)G0 TO 31 
A(I,J)«A(I,J)+U(IK,JL,l)*U(K,L,2) 
B(I, J)-B(I, J)+V(IK, JL, 1)*V(K,L,2) 

31 CONTINUE 
RETURN 
END 


0339 

0340 C 

0341 C 

0342 C 

0343 C 

0344 C 

0345 C 

0346 C 

0347 C 

0348 

0349 

0350 C 

0351 C 

0352 C 

0353 

0354 

0355 

0356 

0357 

0358 

0359 

0360 

0361 C 

0362 

0363 

0364 

0365 C 

0366 C 

0367 C 

0368 

0369 

0370 

0371 

0372 

0373 

0374 C 

0375 

0376 

0377 

0378 

0379 

0380 C 

0381 

0382 

0383 

0384 C 

0385 

0386 

0387 

0388 C 

0389 

0390 

0391 

0392 C 

0393 

0394 

0395 


SUBROUTINE TDLPF(A,B,MN,RC,NDIM,LU) 

INPUTS 

N - NUMBER OP FILTER STAGES 
RC - RELATIVE CUTOFF FREQUENCY FOR FILTER 
NDIM - ARRAY DIMENSION IN CALLING PROGRAM 
OUTPUTS 

A - COEFFICIENT ARRAY (NUMERATOR) 

B - COEFFICIENT ARRAY (DENOMINATOR) 

DIMENSION A(3,3,NDIM),B(3,3,NDIM) 

COMPLEX P(iO),PK,Q,Zi,Z2 

INITIALIZE 


N-MN-1 

PI-3.141592654 

D-1.0E-10 

IF(N.GT.NDIM) GO TO 300 
J,F(0.01.GT.RC.OR.0.99.LT.RC) GO TO 400 
AA-0.5*PI*RC 
AA-SIN(AA)/COS(AA) 

PWR-1 .0/FLOAT(N) 

EPS-SQRT(2.0)-1.0 

EPS-1.0 

EPS-EPS**PWR 

C-AA**2/EPS 

FIND ROOTS 


L-l 

NN-2 .0*N 

CONST-FLQAT( NN+l ) /FLOAT ( NN ) 

DO 10 K-l.NN 

THETA-PI* (1 . 0+2 . 0*(K-1 ) )*C0NST 
PK-C*CMPLX(COS(THETA) , SIN(THETA) ) 

WRITE(LU,14) PK 

14 FORMATC PK - **,1E15.5,** + J**,1E15.5/) 

Q-2.0-PK 

IF(CABS(Q).LE.D) Q-D 

IF(CABS(PK) .LE.D) PK-SIGN(D,REAL(PK)) 

Zl-( 2 . O+PK+2 . 0*CSQRT( 2 .0*PK))/Q 
WRITE(LU, 12) Z1 

12 FORMATC* Zi - **,1E15.5," + J**,IE15.5/) 
IF(CABS(Zi).GE.1.0) GO TO 15 
P(L)-Zl 

WRITE(LU,ll) L, P(L) 

11 FORMAT(” P(” ,112,*’) - **,1E15.5,” + J**,1E15.5/) 
L-L+l 

15 Z2-(2.0+PK-2.0*CSQRT(2.0*PK))/Q 

WRITE(LU, 13) Z2 

13 FORMATC* Z2 - **,IE15.5,*’ + J*',1E15.5/) 
IF(CABS(Z2).GE.1.0) GO TO 20 

F ( L)-Z2 

WRITE(LU, ll) L, P(L) 

L-L+l 

20 IF ( (L-l) .EQ.NN) GO TO 25 
19 CONTINUE 


039b 

039? 

0393 

0399 

0400 

0401 

0402 

0403 

0404 

0405 

0406 

0407 

0408 

0409 

0410 

0411 

0412 

0413 

0414 

0415 

0416 

0417 

0418 

0419 

0420 

0421 

0422 

0423 

0424 

0425 

0426 

0427 

0428 

0429 

0430 

0431 

0432 

0433 

0434 

0435 

0436 

0437 

0438 

0439 

0440 

0441 

0442 

0443 

0444 

0445 


PAIR COMPLEX PAIRS OF ROOTS 
25 L-l 

DO 30 X-l.NN 
Si"AIMAG(?(X) ) 

IF(Sl.LT.O.O) GO TO 30 
P(L)-?(X) 

L*L+1 

30 CONTINUE 


OBTAIN FILTER COEFFICIENTS 

I?((L-i).LT.N) GO TO 500 
DO 40 K-l.N 
C1»-2.0*REAL(?(X)) 
C2-CA3S(P(K))**2 
AM-(1.0+C1+C2)**2/16.0 

A(1,1,K)-AM 

A ( 1 , 2 , X ) »2 . 0*AM 

A(2,1,K)-2.0*AM 

A(1,3,X)-AM 

A( 3 , 1 ,K)«AM 

A(2,2,K)»4.0*AM 

A(2,3,X)«2.0*AM 

A(3,2,X)»2.0*AM 

A(3,3,K)«AM 


B(l,l,X)-1.0 
B(2,1,K)-C1 
B(1,2,X)-C1 
B(1,3,X)«C2 
B(3,1,X)-C2 
B(2,2,K)«C1**2 
B(2,3,X)«C1*C2 
B(3,2,X)«C1*C2 
40 B(3,3,K)-C2**2 

GO TO 600 
300 WRITE (LL\ 310) 

310 FOR-'IAT ( " NUMBER OF STAGES TOO LARGE FOR DIMENSION"/) 
GO TO 600 
400 WRITS (LU, 410) 

410 FORMAT ( " FREQUENCY SPECIFICATION OUT OF RANGE"/) 

GO TO 600 
500 WRITE(L'J, 510) 

510 FORMAT ( ” NUMBER OF ROOTS LESS THAN EXPECTED"/) 

600 RETURN 
END 


0446 


BLOCK DATA UORK 

0447 


OOMMON/WORK/WO(75) 

0448 


END 

0449 


SUBROUTINE HP48A( JJ) 

0450 


DIMENSION IB(14),IA(4) 

0451 


INTEGER IDCB( 144 ),BUFF( 4 ), NAME ( 3 ) 

0452 


DATA NAME/ 2HDA , 2HTA , 2111 / 

0453 

C 


0454 


CALL OPEN(IDCB, IERR, NAME) 

0455 


IF (IERR .GE. 0) GO TO 30 

0456 


WRITE(LU.IO) IERR 

0457 

10 

ORMAT ("OPEN ERROR",F5.0) 

0453 


STOP 

0459 

30 

CALL GRAFC(l.LU) 

0460 

20 

CALL READF ( TDCB , IERR, BUFF , 4 , ILOG) 

0461 


IF( ILOG .EQ. -1) CO TO 55 

0462 


IF (IERR .GE. 0) GOTO 40 

0463 


WRITE(LU, 31) IERR 

0464 

31 

FORMAT( "READ ERROR", F5.0) 

0465 


GO TO 55 

0466 

40 

CONTINUE 

0467 


CALL DVECT(BUFF,BUFF(2),BUFF(3),BUFF(4) 

0468 

50 

GO TO 20 

0469 

55 

CALL EXEC(13,LU,ISTAT) 

0470 


ISTAT“I\ND( ISTAT , 1 40000B ) 

0471 


IF(ISTAT.NE.O) GO TO 55 

0472 


CALL GRAFC(O.LU) 

0473 


CALL CLOSE(IDCB) 

0474 


RETURN 

0475 


END 

0476 


SUBROUTINE GRAFC(IFLAG.LU) 

0477 


INTEGER IESC 

0478 


IESC- 33B 

0479 

C 


0480 

C 

GRAPHICS OFF-O; GRAPHICS ON NOT-O 

0481 

C 


0482 


IF(IFLAG.EQ.O) GO TO 100 

0483 

C 


04 e 4 

C 

GRAPHIC ON 

0485 

c 


0486 


WRITE(LU.IO) IESC 

0487 

10 

F0RMAT(lR2,"*dC") 

0488 


WRITE(LU, 12) IESC 

0489 

12 

FORMAT ( 1R2 , "*dF” ) 

0490 


WRITE(LU, 14) IESC 

0491 

14 

FORMAT ( 1R2 , ” *dA " ) 

0492 

C 



GO TO 200 


0493 

0494 

0495 

0496 

0497 

0498 

0499 

0500 

0501 

0502 

0503 

0504 

0505 

0506 

0507 

0508 

0509 

0510 

0511 

0512 

0513 

0514 

0515 

0516 

0517 

0518 

0519 

0520 

0521 

0522 

0523 

0524 

0525 

0526 


C 

C GRAPHICS OFF 
C 

100 WRITE(LU,3Q) IESC 

30 FORMAT ( 1R.2 , ) 

WRITE(LU,40) IESC 

40 F0RMAT(lR2,"*dE") 

200 RETURN 

END 

SUBROUTINE DVECT(IX1 , IY1 , 1X2, IY2 , LU) 

C 

C SUBROUTINE DRAWS A LINE BETWEEN THE TWO POINTS (IX1.IY1) 
C AND (IX2.IY2). THE POINT (IXO.IYO) DEFINES THE 

C THE ORIGIN. 

C 

1X0-0 

IY0-0 

XSCAL -356.0/1024.0 
YSCAL -XSCAL 
XI - IX1*XSCAL +0.5 
X2 - IX2*XSCAL +0.5 
Y1 - IY1+YSCAL +0.5 
Y2 - IY2*YSCAL +0.5 
JX1 - XI + 1X0 
JX2 - X2 + 1X0 
JY1 * Y1 + IYO 
JY2 - Y2 + IYO 

WRITE(LU.IO) JX1,JY1, JX2.JY2 
10 FORMAT ("pa", 1 13, 1H, ,113, 1H, ,113,1’!, ,H3,"Z") 

RETURN 

END 

END$ 

$ 
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0001 

0002 

0003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 
0011 
0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 
0021 
0022 

0023 

0024 

0025 

0026 
0027 
0023 

0029 

0030 

0031 

0032 

0033 

0034 

0035 

0036 

0037 

0038 

0039 

0040 

0041 

0042 

0043 

0044 

0045 

0046 

0047 

0048 

0049 

0050 

0051 


FTN4 

PROGRAM BLDIM 
C 

C THIS PROGRAM BUILDS AN IMAGE FILE FOR THE NCA&T IMAGE DISPLAY 
C SYSTEM. IMAGE FILES MAY BE GENERATED FROM THE GMR-27 DISPLAY, 

C TAPES OR DISC (TYPE 2 FILES). 

C 

C PROGRAMMER: DU 
C 

DIMENSION LU(5),IDCBl(272),IDCB2(528),NAME(6),ISIZE(2),IDATA 
DIMENSION JNAME(3) ,IBUF(6) 

C 

INTEGER ENTRY(256),TEXT1(40),TEXT2(40),TEXT3(40),RDREC 
C 

EQUIVALENCE (ENTRY k NAME ) , (ENTRY(7) ,NLINE) , (ENTRY(8) ,NPIXL) , 

1 (ENTRY(9) ,IPMIN) , (ENTRY(IO) ,IPMAX) , (ENTRY(ll) ,ISRC) , 

2 (ENTRY( 13) , JNAME) , (ENTRY(129) .TEXTl ) , (ENTRY ( 169) ,TEXT2), 

3 ( ENTRY ( 209) ,TEXT3) , (ENTRY( 12) , ILOC) 

EQUIVALENCE (JNAME(2) , JNAM2) , ( JNAME(3) , JNAM3) , (ISIZE(2) ,ISIZ 
C 

C CONSTANTS 

C MPIXL - MAXIMUM PIXELS/LINE (WHEN CHANGING BE SURE TO MODIF 

C ARRAY SIZES) 

C 

DATA MPIXL/512/ 

C 

C GET INPUT PARAMETERS 
C 

CALL RMPAR(LU) 

IF (LU .LE. 0) LU - 1 
C 

C OUTPUT HEADING 
C 

WRITE(LU.l) 

1 F0RMAT(//’* BUILD IMAGE SUBSYSTEM" 

C 

C OPEN DIRECTORY FILE 
C 

CALL OPEN(IDCBl ,IERR, 6HIMDIRC,0 , 2KIM.23, 272) 

IF (IERR .LT. 0) GO TO 9999 
C 

C GET IMAGE NAME 
C 

1000 WRITE(LU, 2) 

2 FORMAT ( "ENTER 12 CHARACTER IMAGE NAME? ( /E TO EXIT)_") 
READ(LU, " NAME 

3 FORMAT(6A2) 

IF (NAME .EQ. 2H/E) GO TO 1060 
C 

C CHECK FOR DUPLICATE NAME 
C 






0052 

0053 

0054 

0055 

0056 

0057 

0058 

0059 

0060 
0061 
0062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 
0073 

0079 

0080 
0081 
0082 

0083 

0084 

0085 
0085 

0087 

0088 

0089 

0090 

0091 

0092 

0093 

0094 

0095 

0096 

0097 

0098 

0099 

0100 
0101 
0102 

0103 

0104 

0105 

0106 


IREC » 0 
ICREC - 0 

CALL RWNDF(IDCBl.IERR) 

IF (IERR .LT. 0) GO TO 9999 
1010 IREC - IREC ♦ l 

CALL READF ( IOCB l , IERR, IBUF , 6 , LEN) 

IF (IERR .LT. 0) GO TO 9999 
IF (LEN .EQ. -1) GO TO 1030 
C 

C COMPARE NAME 
C 

IF (IBUF .EQ. -1) KREC - IREC 
C 

DO 1020 1-1,6 

IF (NAME(I) .NE. IBUF(I)) GO TO 1010 
1020 CONTINUE 
C 

C DUPLICATE NAME FOUND 
C 

WRITE(LU,4) 

4 FORMAT ("ERROR-DUPLICATE NAME") 

CALL RWNDF( IDCBl , IERR) 

IF (IERR .LT. 0) GO TO 9999 
GO TO .1000 
C 

C EOF REACHED AND NO DUPLICATE FOUND 
C 

C GET IMAGE PARAMETERS 
C 

1030 WRITE(LU, 5) 

5 FORMAT ( "// LINES IN IMAGE ?_”) 

READ(LU,*) NLINE 
WRITE(LU,6) 

6 FORMAT( " if PIXELS/LINE?_") 

READ(LU,*) NPIXL 

IF (NPIXL .GT. MPIXL) NPIXL - MPIXL 
C 

C GET 3-LINES OF DESCRIPTIVE TEXT 
C 

WRITE(LU, 7) 

7 FORMAT(" ENTER UP TO 3 LINES OF DESCRIPTIVE TEXT”/) 

TEXT l - 2H 

CALL MVW(TEXTl ,TEXTi(2) , 119) 

CALL EXEC( 1 ,400B+LU,TEXTl ,40) 

CALL EXEC(1,400B+LU,TEXT2,40) 

CALL EXEC(i,400B+LU,TEXT3,40) 

C 

C GET SOURCE OF IMAGE 
C 

1040 WRITE(LU,8) 

8 F0RMAT( "IMAGE SOURCE? ( 1-DISC FILE ; 2-TAPE ; 3-DISPIA Y; 4-WORK FI 
READ(LU,*) I SRC 

IF (ISRC .LT. 0) CO TO 1060 
IF (ISRC .LT. 1 .OR. ISRC .GT. 4) GO TO 1040 
C 


0107 

0108 

0109 

0110 
0111 
0112 

0113 

0114 

0115 

0116 

0117 

0118 

0119 

0120 
0121 
0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 

0132 

0133 

0134 

0135 

0136 

0137 

0138 

0139 

0140 

0141 

0142 

0143 

0144 

0145 

0146 

01 4 7 

0148 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158 

0159 

0160 


C CREATE DATA FILE 
C 

ISIZE - (FLQAT( NPIXL) *FLQAT( NLINE) + 127.)/ 128. 
ISIZ2 - NPIXL 

IF (KREC .EQ. 0) KREC - IREC 
JNAME - 2HIM 

CALL DCODE ( KREC , JNAM2 , JNAM3 ) 

CALL PURGE ( IDCB2 , IERR, JNAME , 2H IM , 2 3 ) 

CALL CREAT( IDCB2 , IERR, JNAME , ISIZE , 2 , 2HIM , 23 , 528) 
IF (IERR .LT. 0) GO TO 9999 
C 

C INITIALIZE INPUT ROUTINE 
C 

IERR - RDREC(-LU, ISRC, NLINE , NPIXL) 

IF (IERR .LT. 0) GO TO 9999 
C 

C GET EACH LINE AND WRITE TO FILE 
C 

IPMAX - 0 

I PM IN - 377B 

DO 1050 1-1 , NLINE 

IERR - RDREC( 1,1 DATA, IPMAX, IPMIN) 

IF (IERR .LT. 0) GO TO 9999 
CALL WRITE (IDCB2, IERR, IDA TA, NPIXL) 

IF (IERR .LT. 0) GO TO 9999 
C WRITE(LU, 1051) IPMAX, IPMIN 
1051 F0RMAT( 2112) 

1050 CONTINUE 
C 

CALL CLOSE( IDCB2) 

C 

C WRITE DIRECTORY ENTRY 
C 

IF (KREC .EQ. IREC) GO TO 1055 

CALL 0PEN(IDCB1 ,IERR,6HIMDIRC,2 ,2HIM,23, 272) 

IF (IERR .LT. 0) GO TO 9999. 

CALL P0SNTUDCB1, IERR, KREC) 

IF (IERR .LT. C) GO TO 9999 
1055 ILOC - 1 

CALL WRITF(IDCB1, IERR, ENTRY, 256) 

IF (IERR .LT. 0) GO TO 9999 
GO TO 1000 
C 

C TERMINATE 
C 

1060 CALL CLOSE(IDCBl) 

CALL EXEC(6) 

C 

C ERROR 
C 

9999 WRITE(LU,9)IERR 
9 FORMAT ( ” FILE ERROR-”, 16) 

CALL CLOSE(IDCBl) 

END 


0161 


INTEGER FUNCTION RDREC(IC0DE,IBUF,IPl,IP2) 


0162 

C 



0163 

C 

THIS SUBROUTINE IS USED TO INPUT IMAGE FROM DISC, TAPE OR 

DISPLA 

0164 

C 



0165 


DIMENSION IBUF( 1 ) , IDATA( 1024 ) ,NAME( 3) , RDATA( 512) , IDCB( 1040) 

0166 

C 



0167 


LOGICAL PACKED 


0168 

C 



0169 


EQUIVALENCE ( I DATA , RDATA ) 


0170 

C 



0171 

C 



0172 


IF (ICODE .GT. 0) GO TO 120 


0173 

c 



0174 

c 

INITIALIZATION 


0175 

c 



0176 


NLINE - IP1 


0177 


NPIXL - IP2 


0178 


LU - -ICODE 


0179 

c 



0180 


IF (LU .GT. 0) GO TO 90 


0181 

c 



0182 

c 

SPACE FOR CALL WITH NO INTERACTION 


0183 

c 



0184 

c 



0185 

c 

INTERACTIVE CALL 


0186 

c 



0187 

90 

IF (IBUF .NE. 1) GO TO 100 


0188 

c 



0189 

c 

GET DISC FILE NAME 


0190 

c 



0191 


WRITE(LU.l) 


0192 

1 

FORMAT( "ENTER DISC FILE NAME? ") 


0193 


READ(LU,2) NAME 


0194 

2 

FORMAT (3A 2) 


0195 

C 



0196 

C 

OPEN FILE 


0197 

C 



0198 


CALL OPEN( IDCB , IERR , NAME ,0,0,0, 1040) 


0199 


IF (IERR .LT. 0) GO TO 999 


0200 


WRITE(LU, 3) 


0201 

3 

FORMAT C* DATA FORMAT ( l-UNPACKED; 2=PACKED; 3=REAL)?_ 

.") 

0202 


READ(LU,*)IFMT 


0203 


PACKED - .TRUE. 


0204 


IF (IFMT .NE. 2) PACKED =* .FALSE. 


0205 


NUM - NPIXL 


0206 


IF (BACKED) NUM = (NPIXL+l)/2 


0207 


IF (IFMT -EQ. 3) NUM =■ 2*NPIXL 


0208 


IBCOD - 1 


0209 


RETURN 


0210 

c 



0211 

100 IF(IBUF .NE. 2) GO TO 110 


0212 

C 



0213 

c 

TAPE INPUT 


0214 

c 



0215 


WRITE(LU,4) 


0216 

4 

FORMAT ( "TAPE LU? *') 


0217 


READ(LU,*) MTLU 


0218 

C 




0219 

0220 
0221 
0222 

0223 

0224 

0225 

0226 
0227 
0223 

0229 

0230 

0231 

0232 

0233 

0234 

0235 

0236 

0237 

0238 

0239 

0240 

0241 

0242 

0243 

0244 

0245 

0246 

0247 

0248 

0249 

0250 

0251 

0252 

0253 

0254 

0255 

0256 

0257 

0258 

0259 

0260 
0261 
0262 

0263 

0264 

0265 

0266 

0267 

0268 

0269 

0270 

0271 

0272 

0273 

0274 


C REWIND TAPE 
C 

CALL EXEC(3,MTLU+400B) 

WRITE(LU,9) 

9 FORMATC FILE #?_") 

READ(LU,*) IFILE 

IF (IFILE .LE. 0) CALL EXEC(6) 

IF (IFILE .EQ. 1) CO TO 107 
DO 105 I-l.IFILE-l 
CALL EXEC(3,MTLU+1300B) 

105 CONTINUE 
C 

107 WRITE(LU,3) 

READ(LU,*) IFMT 
PACKED - .TRUE. 

IF (IFMT .NE. 2) PACKED - .FALSE. 

NUM - NPIXL 

IF (PACKED) NUM - (NPIXL+D/2 
IF (IFMT .EQ. 3) NUM - 2*NPIXL 
IBCOD - 2 
RETURN 
C 

110 IF (IBUF .NE. 3) GO TO 115 
C 

C DISPLAY INPUT 
C 

WRITE (LU, 5) 

5 FORMAT( "ENTER START LINE, END LINE, START PIXEL, END PIXEL?_") 
READ(LU , * ) ISTRTL , IENDL , ISTRTP , IENDP 
ISTEP - l 

IF (ISTRTL .GT. IENDL) ISTEP - -1 
PACKED - .FALSE. 

NUM - NPIXL 
IBCOD - 3 
RETURN 
C 

C INPUT IS WORK FILE 
C 

115 CALL OPEN(IDCB,IERR,6HWFOOOO, 0,0, 0,1040) 

IF (IERR .LT. 0) GO TO 999 
PACKED » .FALSE. 

NUM - 2*NPIXL 
IBCOD - l 
C 

C POSITION FILE 
C 

CALL READF(IDCB,IERR,IDAIA,0) 

IF (IERR .LT. 0) GO TO 999 
C 

RETURN 

C 

C 

C DATA INPUT SECTION 
C 

C BRANCH TO APPROPRIATE SUB SECTION 
C 


77 


0275 

0276 

0277 

0278 

0279 

0280 
0281 
0282 

0283 

0284 

0285 

0286 

0287 

0288 

0289 

0290 

0291 

0292 

0293 

0294 

0295 

0296 

0297 

0298 

0299 

0300 

0301 

0302 

0303 

0304 

0305 

0306 

0307 

0308 

0309 

0310 

0311 

on2 

0313 

0314 

0315 

0316 

0317 

0318 

0319 

0320 

0321 

0322 

0323 

0324 

0325 

0326 

0327 

0328 

0329 

0330 

0331 


C 

120 GO TO (130, 140,1 50), IBCOD 
C 

C FILE INPUT 
C 

130 CALL REAOF ( IOCB , IERR , RDATA , NUM) 

IF (IERR .LT. 0) GO TO 999 
IFMT-3 
GO TO 160 
C 

C TAPE INPUT 
C 

140 CALL EXEC(1,MTLU,IDATA,NUM) 

GO TO 160 
C 

C DISPLAY INPUT 
C 

150 IBUF - 0 

CALL MVW(IBUF,IBUF(2),NPIXL-1) 

IF ((ISTEP .GT. 0) .AND.(ISTRTL .GT. IENDL)) RETURN 
IF (ISTEP .LT. 0 .AND. ISTRTL .LT. IENDL) RETURN 
CALL RLINE( ISTRTL , ISTRTP , IENDP , I DATA ) 

ISTRTL - ISTRTL + ISTEP 
C 

C MOVE DATA TO OUTPUT ARRAY AND UNPACK IF NECESSARY 
C 

160 IF (.NOT. PACKED) GO TO 180 
C 

C DATA IN PACKED FORMAT 
C 

DO 170 I-l.NUM 
ITEMP - IDATA(I) 

CALL R0T8( ITEMP, JTEMP) 

JTEMP - IAND( JTEMP „377B) 

IF (JTEMP .GT. IP1) IP1 ■ JTEMP 
IF (JTEMP .LT. IP2) IP2 - JTEMP 
ITEMP - IAND( ITEMP, 377B) 

IF (ITEMP .GT. IP1) T.Pi - ITEMP 

IF (ITEMP .LT. IP2) IP2 - ITEMP 

IBUF(2*I-1) - JTEMP 
170 IBUF(2*I) - ITEMP 
RETURN 
C 

C DATA IS UNPACKED 
C 

180 DO 190 I-l.NPIXL 
ITEMP - IDATA(I) 

IF ( IFMT .EQ. 3) ITEMP - RDATA(I) 

IF (ITEMP .GT. IPl) IP1 - ITEMP 

IF (ITEMP .LT. IP2) IP2 - ITEMP 

190 IBUF(I) - ITEMP 
RETURN 
C 

999 RDREC - IERR 
END 

$ 

$ 


&LFLTR T-00003 IS ON CR00022 USING 00024 BLKS R-0000 


0001 

0002 

0003 

0004 

0005 

0006 
0007 
■>008 

0009 

0010 
0011 
0012 

0013 

0014 

0015 

0016 
0017 
0013 

0019 

0020 
0021 
0022 

0023 

0024 

0025 

0026 
0027 
0023 

0029 

0030 

0031 

0032 

0033 

0034 

0035 

0036 

0037 

0038 

0039 

0040 
0341 

0042 

0043 

0044 

0045 

0046 

0047 

0048 


FTN4.L 

PROGRAM LFLTR 
C 

C WRITTEN BY E. E. SHERROD 
C 

C PROCRAM DOES LINEAR FILTERING USING SPATIAL DOMAIN 

C RECURSIVE DIGITAL FILTERS 

C 

C 

C 

C 

c 

DIMENSION A(3,3,2),B(3,3,2),ILU(5),SUM(3,2) 
DIMENSION F1(524),F2(524),F3(524) 

DIMENSION Gl(l),G2(i),G3(l), 1X1(3) 

DIMENSION X1(524),X2(524),X3(524) 

DIMENSION IDCB(144),NAME(3),IRTN(5) 

COMMON /IBLK/IBUF(80) 

INTEGER REA DL , RITEL , WF I NT 

EQUIVALENCE ( IBUF( 1) ,A(l,l,l)) , (IBUF(4i) ,8(1,1,!)) 
EQU IVALENCE( IRTN( 2 ) , RMAX) , ( IRTN( 4 ) , RMIN) 

DATA NAME/2HCO , 2HEF , 2HFS/ 

C 

C NROW X 512 IMAGE 
C 

CALL RMPAR(ILU) 

C 

LU-ILU(l) 

IPIXL-ILU(2) 

JPIXL»ILU(3) 

C 

C GET FILTER COEFF'S 

CALL OPEN( IDCB , IERR, NAME) 

IF(IERR .LT. 0) GO TO 9999 

CALL READF(IDCB, IERR, IBUF, 80, IERR) 

IF(IERR .LT. 0) GO TO 9999 
NSTAG - ?.LUF(40) 

N - NSTAG + l 

CALL CLOSE( IDCB, IERR) 

C 

C GET CONTROL BLOCK INFORMATION 
C 

IERR-WFINT( NROW , ICOLS , RMAX , RMIN , LU) 

IF(IERR .LT. 0)GOTO 9999 
IPIXL - 2 
ICOLS-ICOLS-2 
JPIXL -ICOLS - 1 
C 


79 


0049 

0050 

0051 

0052 

0053 

0054 

0055 

0056 

0057 

0058 

0059 

0060 
0061 
0062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 
0073 

0079 

0080 
0081 
0082 

0083 

0084 

0085 

0086 
0087 
0083 

0089 

0090 

0091 

0092 

0093 

0094 

0095 

0096 

0097 

0098 

0099 

0100 
0101 
0102 

0103 

0104 

0105 


C 

C INITIALIZE FILTER TO MID LiME-CGL AVG 

C 

NMID-NROW/2 

CNST-0.0 

IERR-READL( NMID , 0 , 51 l , FI ) 

IF(IERR .LT. 0) GO TO 9999 
701 DO 110 1*1 , I COLS 

110 CNST-CNSTfFl(I) 

602 CNST-CNST/FL0AT(IC0L3) 

C 

DO 13 1-1,524 

F3(I)-CNST 

F2(I)-CNST 

13 Fi(I)*CNST 
C 

C CALCULATE FINAL VALUE FOR EACH STAGE 

C 

DO 10 NSTG-2 ,N 
SUM(NSTG,1)*0.0 
SUM(NSTG,2)-0.0 
DO 11 1-1,3 
DO 11 J-1,3 

SUM(NSTG, 1)-SUM(NSTG, 1)+A(I, J,NSTG-1) 

11 SUM(NSTG,2)-SUM(NSTG,2)+B(I,J,NSTG-1) 
DEL-ABS(SUM(NSTG,2)) 

IF(DEL.LT . 1 .0E“20)CALL EXEC( 2 ,LU, 16HFILTER UNSTABLE ,8) 
10 SUM(NSTG, 1)*SUM(NSTG, 1)/SUM(NSTG, 2) 

C 

C CALCULATE INITUL CONDITIONS FOR EACH STAGE 

C 

SUM( 1 , 2)*CNST 
DO 12 NSTG-2 ,N 

12 SUM(NSTG, 2)-SUM(NSTG, 1)*SUM(NSTG-1 ,2) 

C 

C INITIALIZE FILTER 

C 

DO 14 1-1,524 
X3(L)-SUM(2,2) 

X2(I)-SUM(2,2) 

X1(I)«SUM(2,2) 

IF (NSTAG .EQ. 1) GO TO 14 
G3(I) - SUM(3,2) 

G2( I)-SUM(3, 2) 

G1(I)-SUM(3,2) 

14 CONTINUE 
RMX— 1.0E38 
RMI- 1.0E38 

C 

C FILTER REVERSE 

C 

IERR-R£ADL(8,IPIXL,JPIXL,F3) 

IF(IERR .LT. 0) GO TO 9999 
ierr-readl(7,ipixl,jpix:l,f2) 

IF(IERR .LT. 0) GO TO 9999 
IERR-READL( 6 , IPIXL , JPIXL , FI) 

IFflERR .LT. 0) GO TO 9999 


80 


0106 

C 


0107 


LNCK * 1 

0108 


DO 300 NRO— 6.NROW - 1,3 

0109 


CALL FILTR(2,F1,F2,F3,X1,X2.X3,GI,NSTAG,IC0LS) 

0110 


IF ( LNCK .LT. 7) GO TO 301 

0111 


LINE - IABS(NRO) 

0112 


CALL RITLN(LINE, IPIXL, JPIXL,Xl ,Gl , NSTAG, 2,LU,RMX,RMI) 

0113 

301 

LNCK -LNCK +1 

0114 


LINE-IABS(NRO+l) 

0115 


IF (LINE .GT. NROW-i) GO TO 300 

0116 


IERR-READL(LINE, IPIXL , JPIXL , F3) 

0117 


IF(IERR .LT. 0) GO TO 9999 

0118 


CALL FILTR(2,F3,Fl,F2,X3,Xl,X2,Gl,NSTAG,ICOLS) 

0119 


IF (LNCK .LT. 7) GO TO 302 

0120 


CALL RITLN(LINE , IPIXL , JPIXL , X3 , G 1 , NSTAG , 2 , LU , RMX , RMI ) 

0121 

302 

LNCK -LNCK +1 

0122 


LlNE-IABS(NR0+2) 

0123 


IF (LINE .GT. NROW-1) GO TO 300 

0124 


IERR-READL(L1NE , IPIXL, JPIXL, F2) 

0125 


IF(IERR .LT. 0) GO TO 9999 

0126 


CALL FILTR(2,F2,F3,F1 ,X2,X3, XI, Gl, NSTAG, ICO LS) 

0127 


IF (LNCK .LT. 7) GO TO 303 

0128 


IF(LINE .GT. NROW-1) GO TO 300 

0129 


CALL RITLN(LINE , IPIXL .JPIXL , X2 ,G 1 , NSTAG , 2 ,LU , RMX , RMI ) 

0130 

303 

LNCK -LNCK +1 

0131 


LINE-IABS(NR0+3) 

0132 


IF (LINE .GT. NROW-l) GO TO 300 

0133 


IERR-READL(LINE , IPIXL , JPIXL , FI ) 

0134 


IF(IERR .LT. 0) GO TO 9999 

0135 

300 

CONTINUE 

0136 

C 


0137 

C REINITIALIZE FILTER 

0138 

C 


0139 


CONST- (RMX-RMI)/2. 

0140 


DO 15 11-1,524 

0141 


Fl(II) - CONST 

0142 


F2(II) - CONST 

0143 


F3(II) - CONST 

0144 

15 

CONTINUE 

0145 

C 


0146 

C 

FILTER FORWARD 

0147 

C 


0148 


RMX— 0.1E38 

0149 


RMI- 0.1E38 

0150 


LINE -NROW-9 

0151 


IERR-READL(LINE, IPIXL, JPIXL, F3( 12)) 

0152 


IF (IERR .LT. 0) GO TO 9999 

0153 


l.INE-LINE+l 

0154 


IERR-READL(LINE, IPIXL, JPIXL, F2( 12)) 

0155 


IF( IERR .LT. 0) GO TC 9999 

0156 


LINE-LINE+i 

0157 


1ERR-READL(LINE, IPIXL, JPIXL, Fl(12)) 

0158 


IF (IERR .LT. 0) GO TO 9999 


81 


0159 

C 


0160 


LNCK —6 

0161 


DO 400 NRO- -6.NR0W -1,3 

0162 


CALL FILTR( 1 ,F1 ,F2,F3 ,Xl ,X2,X3,Gl ,NSTAG , ICOLS) 

0163 


IF (LNCK .LT. 0) GO TO 401 

0164 


CALL RITLN(LINE, IPIXL, JPIXL, Xl ,Gi .NSTAG , l ,LU,RMX,RMI) 

0165 

401 

LNCK-LNCK+l 

0166 


LINE-(NRGW-1 )-IABS(NR0+l ) 

0167 


IERR-READL(LINE,IPIXL,JPIXL,F3<12)) 

0168 


IF(IERR .LT. 0) GO TO 9999 

0169 


CALL FILTR( 1,F3, FI, F2,X3, XI, X2.GI, NSTAG, ICOLS) 

0170 


IF (LNCK .LT. 0) GO TO 402 

0171 


CALL RITLN(LINE, IPIXL, JPIXL, X3,G1 , NSTAG , 1 ,LU,RMX,RMI) 

0172 

402 

LNCK -LNCK +1 

0173 


LINE-( NROW-l )-IABS ( NR0+2 ) 

0174 


IF(LINE .LT. 0) GO TO 400 

0175 


IERR-READL(! INE , IPIXL, JPIXL ,F2( 12) ) 

0176 


IF(IERR .LV. 0) CO TO 9999 

0177 


CALL FILTR( 1, F2,F3, FI, X2,X3, XI ,Gi, NSTAG, ICOLS) 

0178 


IF (LNCK .LT. 0) GO TO 403 

0179 


CALL RITLN( LINE, IPIXL, JPIXL, X2,G1, NSTAG, 1 ,LU,RMX,RMI) 

0180 

403 

LNCK -LNCK +1 

0181 


LINE-( NROW-l )-LABS(NR0+3) 

0182 


IF(LINE . LT.O) GO TO 400 

0183 


IERR»READL( LINE, IPIXL, JPIXL,F1( 12)) 

0184 


IF( IERR .LT. 0) GO TO 9999 

0185 

400 

CONTINUE 

0186 

C 


0187 

51 

CONTINUE 

0188 


RMAX-RMX 

0189 


RMIN-RMI 

0190 


CALL CLSWF(NROW, ICOLS, RMAX.RMIN) 

0191 


CALL PRTN(IRTN) 

0192 


CALL EXEC(6) 

0193 

9999 

CALL EXEC.(2 ,LU, 16HREAD FILE ERROR ,8) 

0194 


END 

0195 


SUBROUTINE FILTR( IFLAG , FI ,F2 ,F3 , XI ,X2 , X3 ,Gl , NSTAG , ICOLS) 

0196 


DIMENSION F 1 ( 1 ) , F2( 1 ) ,F3( 1) ,X1( 1 ),X2(l),X3(i),A(l),B(l) 

0197 


COMMON /IBLK/IBUF(80) 

0198 


DIMENSION Gl(l),G2(l),G3(l) 

0199 

C 


0200 


EQUIVALENCE ( IBUF ,A) , (IBUF(41) , B) 

0201 

C 

IFLAG -1 FOR FORWARD FILTERING, - 2 FOR REVERSE 

0202 

C 


0203 

C REVERSE FILTERING 

0204 

C 


0205 


IF( IFLAG .EQ. 1) GO TO 200 

0206 


DO 20 1-1,11 

0207 


L -ICOLS+12 - I 

0208 


J - ICOLS-12 + I 

0209 


F1(L) - Fi(J) 

0210 


F2(L) - F2(J) 

0211 

20 

F3(L) - F3(J) 

0212 

C 



0213 



DO 10 M - IC0LS+9, 1,-1 

0214 



J - M + 1 

0215 



K - M +2 

0216 



Xl(M) - A(l) * Pl(-:) 

0217 


1 

+ A(2) * Fl(J)-B(2)*Xl(J) 

0213 


l 

+ A(3) * P1(K)-B(3)*X1(K) 

0219 


l 

+ A(4) * P2(M)-B(4)*X2(M) 

0220 


1 

+ A(5) * F2(J)-8(5) *X2(J) 

0221 


1 

+ 4(6) * F2(K)-B(6) *X2(K) 

0222 


l 

+ A(7) * F3(M)-B(7)*X3(M) 

0223 


l 

+ A(8) * F3(J)-B(8) *X3(J) 

0224 


1 

+ A(9) * F3(K) - B(9)*X3(K) 

0225 



IF ( NSTAG .EQ. 1) GO TO 10 

C 



G1(M) - A(10) * X1(M) 

022/ 


1 

+ A(ll) * Xl(J)-B(ll)*Gl(J) 

0223 


i. 

+ A(12) * X1(K)-B(12)*GI(K) 

0229 


1 

+ A(13) * X2(M)-B(13)*G2(M) 

0230 


I 

+ A(14) * X2(J)-B(14) *G2(J) 

0231 


l 

+ A(15) * X2(K)-B(15) *G2(K) 

0232 


l 

+ A(16) * X3(M)-B(16)*G3(M) 

0233 


l 

+ A(17) * X3(J)-B(I7) *G3(J) 

0234 


1 

+ A(18) * X3(K) - B(18)*G3(K) 

0235 

10 


CONTINUE 

0236 



GO TO 400 

0237 

200 


CONTINUE 

0238 

C 



0239 

C FORWARD FILTERING 

0240 

C 



0241 



DO 30 1-1,11 

0242 



L -12 - I 

0243 



J - 12 + I 

0244 



F1(L) - Fl( J) 

0245 



F2(L) - F2( J) 

0246 

30 


F3(L) - F3(J) 

0247 

C 



0248 



DO 40 M - 3, ICOI.S + 11 

0249 



T - M - 1 

0250 



K - M -2 

0251 



X1(M) - A(l) * F1(M) 

0252 


l 

+ A(2) * Fl( J)-B(2)*Xl( J) 

0253 


l 

+ A( 3) * F1(K)-B(3)*X1(K) 

0254 


1 

+ A(4) * F2(M)-B(4)*X2(M) 

0255 


I 

+ A( 5) * F2(J)-B(5) *X2(J) 

0256 


I 

+ A(6) * F2(K)-B(6) *X2(K) 

0257 


1 

+ A ( 7 ) * F3(M)-B(7)*X3(M) 

0258 


1 

+ A(8) * F3(J)-B(8) *X3( J) 

0259 


l 

+ A(9) * F3(K) - B(9)*X3(K) 

0260 



IF (NSTAG .EQ. 1) GO TO 40 

0261 



G1(M) - A( 10) * X1(M) 

0262 


1 

+ A(ll) * Xl( J)-B( 11)*G1( J) 

0263 


I 

+ A(12) * X1(K)-B( 12)*G1(K) 

0264 


1 

+ A( 13) * X2(M)-B(13)*G2(M) 

0265 


l 

+ A( 14) * X2( J)-B( 14) *G2( J) 

0266 


1 

+ A(15) * X2(K)-B( 15) *G2(K) 

0267 


1 

+ A(16) * X3(M)-B(16)*G3(M) 

0268 


1 

+ A(17) * X3(J)-B( 17) *G3( J) 

0269 


1 

+ A(18) * X3(K) - B(18)*G3(K) 

0270 

40 


CONTINUE 

0271 

400 


CONTINUE 

0272 



RETURN 

0273 



END 
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0274 

C 


0275 

C 

COMMON BLOCK SUBPROGRAM 

0276 

C 


0277 


BLOCK DATA IBLK 

0278 


COMMON /IBLK/IBUF(80) 

0279 


DATA JBUF/80*0/ 

0280 


END 

0281 


SUBROUTINE RITLN(LINE, IPIXL, JPIXL, XI, Gl,NSTAG,IFLAG,LU,RMX,R 

0282 


DIMENSION Xl(l),Gl(l), 1X1(524) 

0283 


INTEGER RITEL 

0284 


IFL-1 

0285 


IF ( IFLAG .EQ. 1) IFL ■ 12 

0286 


IF(NSTAG .EQ. 2) GO TO 100 

0287 


IERR- R1TEL(LINE, IPIXL, JPIXL, XI (IFL)) 

0288 

12 

IF( IERR .LT. 0) GO TO 9999 

0289 


DO 120 I-IFL.JPIXL-IPIXL +IFL 

0290 


IF(X1(I) .GT. RMX) RMX-Xl(I) 

0291 


IF(X1(I) .LT. RMI) RMI-Xl(I) 

0292 


ITEMP- X1(I) + 0.5 

0293 


IF(ITEMP .LT. 0) ITEMP-0 

0294 


IF( ITEMP .GT. 377B) ITEMP-3773 

0295 

120 

1X1(1) - ITEMP 

0296 


GO TO 200 

0297 

100 

CONTINUE 

0298 


IERR- RITF.L( LINE, IPIXL, JPIXL, Gl( IFL)) 

0299 


IF( IERR .LT. 0) GO TO 9999 

0300 


DO 121 1-1,524 

0301 


ITEMP-Cl(I) +0.5 

0302 


IF( ITEMP .LT. 0) ITEMP-0 

0303 

121 

IXi(I) -LAND (ITEMP, 7 77B) 

0304 

200 

ISTRT-(5ll-JPIXL)/2 

0305 


ISTOP-ISTRT+JPIXL 

0308 


CALL WLINE(LINE, ISTRT, I STOP, I XI (IFL)) 

0307 


RETURN 

0308 

9999 

CALL EXEC(2,LU, 16HWRITE FILE ERROR, 8) 

0309 


END 

0310 


FND$ 
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&HFLTR T-00004 IS ON CR00022 USING 00036 BLKS R-0289 


0001 

0002 

0003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 
0011 
0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 
0021 
0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

0030 

0031 

0032 

0033 

0034 

0035 

0036 

0037 

0038 
('039 

0040 

0041 

0042 

0043 

0044 

0045 

0046 

0047 

0048 

0049 

0050 

0051 

0052 

0053 

0054 

0055 

0056 


FTN4.L 

PROGRAM HFLTR 
C 

C WRITTEN BY E. E. SHERROD 
C 

C PROGRAM DOES HOMOMORPHIC FILTERING USING SPATIAL DOMAIN 

C RECURSIVE DIGITAL FILTERS 

C 

COMMON /IBLK/IBUF(80) 

DIMENSION IFI(2),IF2(523),R1(523) 

DIMENSION A(3,3,2),B(3,3,2),ILU(5),SUM(3,2) 

DIMENSION F1(523),F2(523),F3(523) 

DIMENSION G1(1),G2(1),G3(1), 1X1(3) 

DIMENSION X1(523),X2(523),X3(523) 

DIMENSION IDCB( 144) ,NAME( 3) ,IRTN(5) 

INTEGER READL,RITEL,WFINT 

EQUIVALENCE ( IBUF (l),A(l,l,l)),( IBUF (41),B(1,1,1)) 

EQi: I VALENCE ( IRTN( 2 ) , RMAX) , ( IRTN( 4 ) , RMIN) 

EQUIVALENCE (F 1 , R1 ) , (F2 , IF2) , (Rl , IF1 ) , ( IF1 , I LINE) , (IFl ( 2 ) , ICO 
1(R1(2),RMAXX),(R1(3),RMINN) 

DATA NAME/ 2HCO , 2HEF , 2HFS/ 

C 

CALL RMPAR(ILU) 

LU-ILU(l) 

IF(LU .EQ. 0) LU-l 
IPIXL - ILU(2) 

IF(IPIXL .EQ. 0) IPIX1 -0 
JPIXL - ILU(3) 

IF(JPIXL .EQ. 0) JPIXL - 511 
C 

C GFT FILTER COEFF'S 

CALL OPEN( I DCB , I E RR , NAME ) 

IF(IERR .LT. 0) GO TO 9999 

CALL READF ( IDCB , IERR, IBUF , 80 , IERR) 

IF(IERR .LT. 0) GC TO 9999 
NSTAG - IBUF(40) 

N = NSTAG + 1 

CALL CLOSE/ IDCB , IERR) 

C 

C GET CONTROL BLOCK INFORMATION 

IERR=rFINT( NROW , ICO LS , RMAX , RMIN , LU) 

IF ( IERR .LT. 0)G0T0 9999 
IPIXL=2 

ICOLS =IC0LS-2 
JPIXL - ICOLS -1 
C 

C INITIALIZE FILTER TO MID LINE-COL AVG 

NMID=NROW/2 
CNST=0.0 

IERR=READL( NMID , IPIXL , JPIXL , FI ) 

IF(IERR .LT. 0) GO TO 99S9 
CALL BIAS(F1, RMIN, ICOLS) 

701 DO 110 1=1, ICOLS 

110 CNST=CNST+AMAX0(F1(I), 1) 

602 CNST=(CNST/ FLOAT ( ICOLS)) 

CNST = ALOG(CNST) 


0058 

0059 

0060 
0061 
0062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

0078 

0079 

0080 
0081 
0082 

0083 

0084 

0085 

0086 

0087 

0088 

0089 

0090 

0091 

0092 

0093 

0094 

0095 

0096 

0097 

0098 

0099 

0100 
0101 
0102 

0103 

0104 

0105 


DO 9 1-1,523 
F1(I) - CNST 
F2(l) - CNST 
F3(I) - CNST 

9 CONTINUE 

C 

C CALCULATE FINAL VALUE FOR EACH STAGE 

DO 10 NSTG-2.N 
SUM(NSTG, l)«0.0 
S UM( NSTG , 2 ) -0 . 0 
DO 11 1-1,3 
DO 11 J-1,3 

SUM(NSTG, 1)-SUM(NSTG, 1)+A(I,J, NSTG-1) 

1 1 SUM( NSTG , 2 ) -SUM( NSTG , 2 )+B ( I , J , NSTG-1 ) 
DEL-ABS(SUM(NSTG,2) ) 

IF(DEL.LT. 1 .0E- 70) CALL EXEC(2,LU, 16HFILTER UNSTABLE ,6) 

1 0 SUM( NSTG , l ) -SUM( NSTG , 1 ) /SUM ( NSTG , 2) 

C 

C CALCULATE INITIAL CONDITIONS FOR EACH STAGE 

SUM(i,2)»CNST 
DO 12 NSTG-2.N 

12 SUM(NSTG, 2)‘*SUM(NSTG, 1)*SU>1( NSTG-1, 2) 

C 

C INITIALIZE FILTER 

DO 14 1-1,523 
X3(I)-(SUM(2,2)) 

X2( I)-(SUM(2 , 2) ) 

X1(I)-(SUM(2,2)) 

IF (NSTAG .EQ. 1) GO TO 14 
G3(I) -( SUM(3,2)) 

G2(I)’*(SUM(3, 2) ) 

G1(I)-(SUM(3,2)) 

14 CONTINUE 

RMX— 1.0E38 
RMI“ 1.0E38 

C 

C FILTER REVERSE 

CALL EXEC(2,LU, 161IREVERSE FILTERIN.8) 

SCL » 1.0 

IERR=*READL( 8 , IPIXL , JPIXL , F3 ) 

IF (IERR .LT. 0) GO TO 9999 
CALL BIAS(F3,RMIN,ICOLS) 

IERR=READL( 7 , IPIXL , JPIXL , F2 ) 

IF (IERR .LT. 0) GO TO 9999 
CALL BIAS(F2 ,RMIN, ICOLS) 

IERR-READL( 6 , IPIXL , JPIXL , FI ) 

IF(IERR .LT. 0) GO TO 9999 

C 
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t fitid nasaa 


86 


0106 

0107 

0108 

0109 

0110 
0111 
0112 

0113 

0114 

0115 

0116 

0117 

0118 
Oil* 
0120 
0121 
0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 

0132 

0133 

0134 

0135 

0136 

0137 

0138 

0139 

0140 

0141 

0142 

0143 

0144 

0145 

0146 

0147 

0148 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158 

0159 

0160 
0161 
0162 

0163 

0164 


LNCK - 1 

DO 300 NRO— 6.NR0W - 1,3 
CALL BIAS(F1 ,RMIN, I COLS) 

CALL HFILT(?, FI, F2,F3, XI, X2,X3,G1, NSTAG, ICOLS) 

IF (LNCK .LT. 7) GO TO 301 
LINE - IABS(NRO) 

CALL RITLN( LINE , IPIXL , JPIXL , XI , Gl , NSTAG , 2 , LU, RMX , RMI , SCL) 

301 LNCK -LNCK +1 
LINE-IABS(NR0+1) 

IF (LINE .GT. NROW-1) GO TO 300 
IERR-READL( LINE, IPIXL, JPIXL, F3) 

IF(IERR .LT. 0) GO TO 9999 
CALL BIAS(F3,RMIN,1C0LS) 

CALL HFILT ( 2 , F 3 , FI , F2 , X3 , XI , X2 , Gl , NSTAG , ICOLS ) 

IF (LNCK .LT. 7) GO TO 302 

CALL RITLN( LINE .IPIXL , JPIXL , X3 ,G1 .NSTAG , 2 , LU , RMX , RMI , SCL ) 

302 LNCK -LNCK +1 

LINE«IABS(NR0+2) 

IF (LINE .GT. NROW-1) GO TO 300 
IERR-READL( LINE , IPIXL , JPIXL , F2 ) 

IF(IERR .LT. 0) GO TO 9999 
CALL BIAS(F2,RMIN, ICOLS) 

CALL HFILT(2,F2,F3,Fl,X2,X3,Xl,Gl, NSTAG, ICOLS) 

IF (LNCK .LT. 7) GO TO 303 
IF (LINE .GT. NROW-1) GO TO 300 

CALL RITLN(LINE, IPIXL, JPIXL, X2.G1, NSTAG, 2, LU, RMX, RMI, SCL) 

303 LNCK -LNCK +1 

LINE-IABS(NR0+3) 

IF (LINE .GT. NROW-1) GO TO 300 
IERR-READL(LINE, IPIXL, JPIXL, Fi) 

IF(IERR .LT. 0) GO TO 9999 
300 CONTINUE 

C 

C REINITIALIZE FILTER 

CONST - (RMX-RMI) /2. 

DO 15 J-1,523 
F 1 ( J ) - CONST 

F2(J) - CONST 

F3(J) - CONST 

15 CONTINUE 
C 

C FILTER FORWARD 

C 

CALL EXEC(2,LU, 16HF0RWARD FILTERIN.8) 

C 

C SCALE FOR LN(32766) 

SCL - 10.397147 /(RMX) 

RMI -0. IE 3 8 
RMX— 0.1E38 
JPIXL-JPIXL-1 
LINE -NROW-9 

IERR=READL(LINE, IPIXL, JPIXL, F3( 12)) 

IF ( IERR .LT. 0) GO TO 9999 
LINE-LINE+l 

IERR”READL(LINE , IPIXL , JPIXL , F2 ( 12) ) 

IF (IERR .LT. 0) GO TO 9999 
LINE-LINE+1 

IERR=REABL(LINE, IPIXL, JPIXL, Fl( 12)) 

IF (IERR .LT. 0) GO TO 9999 
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1)165 

0166 

0167 

0168 

0169 

0170 

0171 

0172 

0173 

0174 

0175 

0176 

0177 

0178 

0179 

0180 
0181 
0182 

0183 

0184 

0185 

0186 

0187 

0188 

0189 

0190 

0191 

0192 

0193 

0194 

0195 

0196 

0197 

0198 

0199 

0200 
0201 
0202 

0203 

0204 

0205 

0206 

0207 

0208 

0209 

0210 
0211 
0212 

0213 

0214 

0215 

0216 

0217 

0218 

0219 

0220 
0221 


C 

LNCK —6 

DO 400 NRO- -6.NROW - 1,3 

CALL HFILT( i,Fl,F2,F3, XI, X2,X3,Gl, NSTAG, ICOLS) 

IF (LNCK .LT. 0) GO TO 401 

CALL RITLN( LINE , IPIXL , JPIXL , XI ,G1 , NSTAG , l , LU , RMX , RMI , SCL) 

401 LNCK-LNCK+1 

L INE- ( NROW- 1 ) - IA BS ( NRO+l ) 

IERR-READL(LINE, IPIXL, JPIXL, F3(12)) 

IF(IERR .LT. 0) CO TO 9999 

CALL HFILT(l,F3, FI, F2,X3,Xi,X2,Gl, NSTAG, ICOLS) 

IF (LNCK .LT. 0) GO TO 402 

CALL RITLN(LINE, IPIXL, JPIXL, X3,G1, NSTAG, l, LU, RMX, RMI, SCL) 

402 LNCK -LNCK +1 
LINE-(NROW-l)-IABS(NRO+2) 

IF (LINE .LT. 0) GO TO 400 

IERR-READL(LINE, IPIXL, JPIXL, F2(12)) 

IF(IERR .LT. 0) GO TO 9999 

CALL HFILT( 1,F2,F3, FI, X2,X3, XI, Gl, NSTAG, ICOLS) 

IF (LNCK .LT. 0) GO TO 403 

CALL RITLN(LINE, IPIXL, JPIXL, X2,Gl , NSTAG, 1 ,LU,RMX,RMI , SCL) 

403 LNCK -LNCK +1 
LINE-(NR0W-1 )-IABS(NR0+3) 

I? (LINE . LT. 0) GO TO 400 

IERR-READL(LIN5, IPIXL, JPIXL, Fl( 12)) 

IF(IERR .LT. 0) GO TO 9999 
400 CONTINUE 

C 

51 CONTINUE 

CALL EXEC(2 ,LU, 10HC0MPLETED ,5) 

C 

CALL CLSWF(NROW, ICOLS, RMX, RMI) 

C 

RMAX - RMX 
RMIN - RMI 
CALL PRTN(IRTN) 

CALL EXEC( 6) 

9999 CALL EXEC(2,LU, 16HREAD FILE ERROR ,8) 

END 

SUBROUTINE HFILT(IFLAG,F1,F2,F3, XI, X2,X3,G1, NSTAG, ICOLS) 
DIMENSION F1(1),F2(1),F3(1),X1(1),X2(1),X3(1),A(1),B(1) 
COMMON /IBLK/IBUF(80) 

DIMENSION Gi(l) ,G2(1) ,G3(1) 

C 

EQUIVALENCE (IBUF.A), (IBUF(41),B) 

C IFLAG -1 FOR FORWARD FILTERING, - 2 FOR REVERSE 
C 

C REVERSE FILTERING 
C 

IF ( IFLAG .EQ. 1) GO TO 200 
DO 20 1-1,11 
L -ICOLS+12 - I 
J - ICOLS-12 + I 
F1(L) - F1(J) 

F2(L) = F2(J) 

20 F3(L) - F3(J) 

C 


0222 



DO 10 M - ICOLS+9, 1,-1 

0223 



J - M + l 

0224 



K - M +2 

0225 



X1(M) - A(l) * ALOG(Fl(M)) 

0226 


l 

+ A(2) * AL0G(F1(J))-B(2)*X1(J) 

0227 


1 

+ A(3) * AL0G(Fl(K))-B(3)*Xl(K) 

0228 


1 

+ A(4) * ALOG(F2(M))“B(4)*X2(M) 

0229 


l 

+ A(5) * AL0G(F2(J))-B(5) *X2(J) 

0230 


1 

+ A(6) * AL0G(F2(K))-B(6) *X2(K) 

0231 


l 

+ A(7) * ALOC(F3(M))-B(7)*X3(M) 

0232 


1 

+ A(8) * ALOG(F3(J))-B(8) *X3(J) 

0233 


l 

+ A(9) * AL0G(F3(K))- B(9)*X3(K) 

0234 



IF(NSTAG .EQ. 1) GO TO 10 

0235 



Gl(M) - A(10) * X1(M) 

0236 


1 

+ A ( 1 1 ) * Xl( J)-B( 11)*G1(J) 

0237 


1 

+ A(I2) * X1(K)-B(12)*G1(K) 

0233 


l 

+ A(13) * X2(M)-B(13)*G2(M) 

0239 


1 

+ A ( 14) * X2(J)-B(14) *G2( J) 

0240 


1 

+ A(15) * X2(K)-B(15) *G2(K) 

0241 


l 

+ A(16) * X3(M)-B( 16)*G3(M) 

0242 


l 

+ A(17) * X3(J)-B(17) *G3( J) 

0243 


l 

+ A(18) * X3(K) - B(18)*G3(K) 

0244 

10 


CONTINUE 

0245 



GO TO 400 

0246 

200 


CONTINUE 

0247 

C 



0248 

C FORWARD FILTERING 

0249 

C 



0250 



DO 30 1-1,11 

0251 



L -12 - I 

0252 



J - 12 + I 

0253 



F1(L) - F1(J) 

0254 



F2(L) - F2( J) 

0255 

30 


F3(L) - F3( J) 

0256 

C 



0257 



DO 40 M - 3.IC0LS+11 

0258 



J = M - 1 

0259 



K - H -2 

0260 



X1(M) - A(l) * FI (M) 

0261 


1 

+ A(2) * F1(J)-B(2)*X1( J) 

0262 


l 

+ A(3) * F1(K)-B(3)*X1(K) 

0263 


1 

+ A(4) * F2(M)-B(4)*X2(M) 

0264 


1 

+ A(5) * F2(J)-B(5) *X2(J) 

0265 


l 

+ A(6) * F2(K)-B(6) *X2(K) 

0266 


1 

+ A(7) * F3(M)-B(7)*X3(M) 

0267 


1 

+ A(8) * F3(J)-B(8) A X3( J) 

0268 


1 

+ A(9) * F3(K) - B(9)*X3(K) 

0269 



IF(NSTAG .EQ. 1) GO TO 40 

0270 



G1(M) - A( 10) * X1(M) 

0271 


1 

+ A(11) * X1;J)-B(11)*G1(J) 

0272 


l 

+ A(12) * X1(X)-B(12)*G1(K) 

0273 


1 

+ A(13) * X2(M)-B( 13)*G2(M) 

0274 


1 

+ A(14) * X2( J)-B( 14) *G2( J) 

0275 


1 

+ A( 15) * X2(K)-B(15) *G2(K) 

0276 


1 

+ A( 16) * X3(M)-B( 16)*G3(M) 

0277 


1 

+ A(17) * X3( J)-B( 17) *G3(J) 

0278 


1 

+ A(18) * X3(K) - B(18)*G3(K) 

0279 

40 


CONTINUE 

0280 

400 


CONTINUE 

0281 



RETURN 

0282 



END 
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0283 

0284 

0285 

0286 

0287 

0288 

0289 

0290 

0291 

0292 

0293 

0294 

0295 

0296 

0297 

0298 

0299 

0300 

0301 

0302 

0303 

0304 

0305 

0306 

0307 

0308 

0309 

0310 

0311 

0312 

0313 

0314 

0315 

0316 

0317 

0318 

0319 

0320 

0321 

0322 

0323 

0324 

0325 

0326 

0327 

0328 

0329 


C 

C COMMON BLOCK SUBPROGRAM 
C 

BLOCK DATA IBLK 
COMMON/ IBLK/ IBUF (80) 

END 

SUBROUTINE RITLN( LINE .IPIXL, JPIXL, XI, G l, NSTAG, IFLAG, LU, RMX, R 
1SCL) 

DIMENSION Xl(l),Gl(i),XXl(523) 

INTEGER RITEL 
C 

C IFLAG -1 FOR FORWARD -2 FOR REVERSE 
C REV 

IF(NST ; \G .EQ. 2) GO TO 12 
IF( IFLAG .EQ. 1) GO TO 11 
DO 10 M=l, JPIXL-IPIXL+l 
IF(X1(M) .GT. RMX) RMX-Xl(M) 

IF(X1(M) .LT. RMI) RMI-Xl(M) 

10 CONTINUE 

IERR-RITEL( LINE , IPIXL , JPIXL , XI ) 

IF( IERR .LT. 0) GO TO 9999 
GO TO 12 
C 

11 CONTINUE 
C FORWARD 

DO 20 M**12 , JPIXL-IPIXL+12 
X»SCL*(X1(M)) 

IF(X .GT. 10.397147) X - 10.397177 
XXI (M) = EXP(X) 

IF(XX1(M) .GT. RMX) RMX=XX1(M) 

IF(XX1(M) .LT. RMI) RMI=XX1(M) 

20 CONTINUE 

IERR= RITEL(LINE, IPIXL, JPIXL, XX1(12)) 

IF( IERR .LT. 0) GO TO 9999 

12 CONTINUE 

RETURN 

9999 CALL EXEC( 2 ,LU, 16UWRITE FILE ERROR, 8) 

END 

SUBROUTINE BIAS(Fl,RMIN,ICOLS) 

DIMENSION Fl(l) 

DO 10 1=1 ,ICOLS + 11 
Fl(l) =* F1(I) - RMIN +1.0 
IF(F1(I) .LT. 1.) F1(I) - 1.0 
10 CONTINUE 
RETURN 
END 
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FTN4 

PROGRAM SHOW 
C 

DIMENSION RDATA(512) ,IDATA(512),LU(5) 

C 

INTEGER READL 

EQUIVALENCE (RDATA,LU(2) ) , (LU(2) ,ILINE) , (LU(3) , IPIXL) , 
1 (RDATA(2),RMAX),(RDATA(3),RMIN) 

C 

C GET INPUT PARAMETERS 
C 

CALL RMPAR(LU) 

C 

C GET SCALE 
C 

WRITE(LU.l) 

1 FORMAT ("INPUT RANGE ?_") 

READ(LU,*)RL,RH 

C 

C READ WORK FILE HEADER 
C 

IERR - READL(-l,0,5ll,RDATA) 

IF (IERR .LT. 0) GO TO 999 

NLINE - ILINE 

NPIXL - IPIXL 

PMAX - RMAX 

PMIN * RMIN 

DO 100 I=0,NLINE-1 

IF (READL(I,0,NPIXL-1,RDATA) .LT. 0) GO TO 999 
DO 90 J -1, NPIXL 

IDATA(J) = RL +((RH-RL)/(PMAX-PMIN))*(RDATA(J)-PMIN) 

IF (IDATA(J) .GT. 255) IDATA(J) = 255 

IF (IDATA(J) .LT. 0) IDATA(J) = 0 

90 CONTINUE 

C 

CALL WLINE(I , 0, 511 ,IDATA) 

100 CONTINUE 

CALL CLSWF (NLINE, NPIXL, PMAX, PMIN) 

CALL EXEC(6) 

999 WRITE(LU, 2) IERR 

2 FORM\T("FILE ERROR", 17) 

END 

$ 




91 


* i 
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H 
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&FIRO T-00004 IS ON CR00022 USING 00003 BLKS R-0023 ] 

0001 FTN4,L 1 

0002 PROGRAM FIRO 

0003 DIMENSION ILU(5) ,IBUF(80) ,A(3 , 3,2) ,H(5 ,5) ,NAME(3) ,IDCB( 144) 1 

0004 DIMENSION NAME 1(3) ,NAME2(3) 1 

0005 EQUIVALENCE (IBUF( 1) ,A( 1 , 1 , 1) ) l! 

0006 DATA H/25*0./ j 

0007 DATA IBUF/80*0/ j 

0008 DATA NAME/ 2HC0 , 2HEF , 2HFS/ | 

0009 DATA NAME 1 / 2HDP , 2HLA , 2HM / J 

0010 DATA NAME2/2HPL. 2!I0f ,2HV / 1 

0011 c 

0012 C GET LU 

0013 CALL RMPAR(ILU) 

0014 LU-ILU 

0015 WRITE(LU.IO) j 

0016 10 FORMAT ( " ENTER NUMBER OF STAGES _") 

0017 READ(LU,*) NSTG i 

0018 IBUF(40)-NSTG I 

0019 C | 

0020 WRITE(LU.ll) j 

0021 11 FORMAT (" ENTER ALPHA VALUE _") 

0022 READ(LU,*) ALPHA 

0023 C 

0024 H(l,l)-1.0 

0025 DO 100 1-1,3 

0026 DO 100 J-1,3 

0027 CALL WINDO(ALPHA, I , J,WIN) 

0028 A(I, J,NSTG)-WIN*H(I, J) 

0029 100 CONTINUE 

0030 CALL PURGE (IDCB, IERR,NAME,2HES) 

0031 IF ( IERR .LT. 0) WRITEfLU, 999) IERR 

0032 CALL CREAT( IDCB , IERR, NAME ,2 , 3 , 2HES) 

0033 IF ( IERR .LT. 0) WRITE(LU, 999) IERR 

0034 CALL WRITF ( IDCB , IERR , IBUF , 80) 

0035 CALL CLOSE( IDCB, IERR) 

0036 C 

0037 C SCHEDULE DISPLAY 

0038 CALL EXEC(23,NAME1,LU, NSTG, 0,0,0, IBUF, 80) 

0039 C 

0040 WRITE(LU,40) 

0041 40 FORMAT(//" ENTER DISPLAY DEVICE "//" 1. TV"/" 2. HP2648A") 

0042 READ(LU,*) IDEV 

0043 IF (IDEV .EQ. 2) GO TO 41 

0044 CALL EXEC(23,NAME2) 

0045 GO TO 42 

0046 41 CONTINUE 

0047 CALL HP48A(LU) 

0048 42 CONTINUE 

0049 999 FORMAT(” FILE ERROR ") 

0050 STOP 

0051 END 



0052 


SUBROUTINE HP48A(LU) 

0053 


DIMENSION IB( 14) ,IA(4) 

0054 


INTEGER IDCB( 144 ),BUFF( 4 ), NAME( 3) 

0055 


DATA NAME/ 2HDA , 2HTA , 2H1 / 

0056 

C 


0057 


CALL OPEN(IDCB, IERR, NAME) 

0058 


IF (IERR .GE. 0) GO TO 30 

0059 


WRITE(LU.IO) IERR 

0060 

10 

FORMAT ("OPEN ERROR", F5.0) 

0061 


STOP 

0062 

30 

CALL GRAFC(l.LU) 

0063 

20 

CALL READ! (IDCB, IERR, BUFF, 4, ILOG) 

0064 


IF ( I LOG .EQ. -1) GO TO 55 

0065 


IF (IERR .GE. 0) GOTO 40 

0066 


WRITE(LU,3i) IERR 

0067 

31 

FORMAT ( "READ ERROR", F5.0) 

0068 


GO TO 55 

0069 

40 

CONTINUE 

0070 


CALL DVECT(BUFF,BUFF( 2) ,BUFF(3) , BUFF(4) ,LU) 

0071 

50 

GO TO 20 

0072 

55 

CALL EXEC( 13 ,LU,ISTAT) 

0073 


ISTAT«IAND( ISTAT , 140000B) 

0074 


IF(ISTAT.NE.O) GO TO 55 

0075 


CALL GRAFC(O.LU) 

0076 


CALL CLOSE(IDCB) 

0077 


RETURN 

0078 


END 

0079 


SUBROUTINE GRAFC(IFLAG.LU) 

0080 


INTEGER IESC 

0081 


IESC- 33B 

0082 

C 


0083 

C 

GRAPHICS OFF-0; GRAPHICS ON NOT-O 

0084 

C 


0085 


IF( IFLAG.EQ.O) GO TO 100 

0086 

C 


0087 

C 

GRAPHIC ON 

0088 

C 


0089 


WRITE(LU.IO) IESC 

0090 

10 

FORMAT( 1R2 , "*dC") 

0091 


WRITE(LU, 12) IESC 

0092 

12 

FORMAT( 1R2 , "*dF") 

0093 


WRITE(LU, 14) IESC 

0094 

14 

FORMAT( IR2 , "*dA ") 

0095 

C 


0096 


GO TO 200 

0097 

C 


0098 

C 

GRAPHICS OFF 

0099 

C 


0100 

100 

WRITE(LU, 30) IESC 

0101 

30 

FORMAT ( 1R2 , "*dd") 

0102 


WRITE(LU,40) IESC 

0103 

40 

F0RMAT( 1R2 , "*dE") 

0104 

200 

RETURN 

0105 


END 
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0106 

0107 

0108 

0109 

0110 
0111 
0112 

0113 

0114 

0115 

0116 

0117 

0118 

0119 

0120 
0121 
0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 


SUBROUTINE DVECT( 1X1 , IY1 , 1X2, IY2 ,LU) 

C 

C SUBROUTINE DRAWS A LINE BETWEEN THE TWO POINTS (IX1.IY1) 
C AND (1X2, IY2). THE POINT (IXO,IYO) DEFINES THE 

C THE ORIGIN. 

C 

1X0-0 

IY0-0 

XSCAL -356.0/1024.0 
YSCAL -XSCAL 
XI - IX1*XSCAL +0.5 
X2 - IX2*XSCAL +0.5 
Yl - IYl*YSCAL +0.5 
Y2 - IY2*YSCAL +0.5 
JX1 - XI + IXO 
JX2 - X2 + IXO 
JY1 - Yl + IYO 
JY2 - Y2 + IYO 

WRITE(LU, 10) JX1, JY1, JX2.JY2 
10 FORMAT( "pa" , 113, 1H, , 113, 1H, , 113 , 1H, , 113, "Z”) 

RETURN 

END 

END$ 

$ 

$ 
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&WINDO T-00004 IS ON CR00022 USING 00003 BLKS R-0012 


0001 FTN4 


0002 

SUBROUTINE WINDO(ALPHA, N,M,WIN) 

0003 

XN-SQRT(M**2 + N**2) 

0004 

BETA«ALPHA*SQRT( I.-XN) 

0005 

CALL BESIO(ALPHA,BIAA) 

0006 

CALL BESIO( BETA, BIBB) 

0007 

BETA 1«ALPHA*SQRT( 2 ) 

0008 

CALL BESI0(BETA1,BIB) 

0009 

ZMIN-BIB/BIAA 

0010 

WIN»(BIB3/BIAA-ZMIN)/(1 .O-ZMIN) 

OOU 

RETURN 

0012 

END 

0013 $ 



&BESI0 T-00004 IS ON CR00022 USING 00002 BLKS R-0015 


0001 

FTN4 


0002 


SUBROUTINE BESIO(X.RIO) 

0003 


RIO-ABS(X) 

0004 


IF(RIO-3.75) 1,1,2 

0005 

1 

Z=X*X*7 .lllillE-2 

0006 


RIO-( ( ( ( (4 . 5813E-3*Z+3. 60768E-2)*Z+2 . 659732E-1 )*Z+1 . 206749E0 

0007 


1089942E0)*Z+3. 515623EO)*Z+i. 

0008 


RETURN 

0009 

2 

Z-3. 75/RIO 

0010 


RIO“EXP(RIO)/SQRT(RIO)*( ( ( ( ( ( ( (3 . 92377 E-3*Z-1 . 647633E-2)*Z+2 

OOU 


l7E-2)*Z-2. 057706E-2)*Z+9. 16281E-3)*Z-1 . 57565E-3)*Z+2. 25319E- 

0012 


2+1 . 328592E-2)*Z+3. 989423E-1) 

0013 


RETURN 

0014 


END 

0015 


END$ 
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&BESJ 

0001 

0002 

0003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 
0011 
0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 
0021 
0022 

0023 

0024 

0025 

0026 
0027 
0023 

0029 

0030 

0031 

0032 

0033 

0034 

0035 

0036 

0037 
0033 

0039 

0040 

0041 

0042 

0043 

0044 

0045 

0046 

0047 

0048 

0049 

0050 

0051 

0052 

0053 

0054 

0055 

0056 

0057 


T “00004 IS ON CR00022 USING 00014 BLKS R-0129 


C 

C 

C 

C 

C 

C 

C 

C 

C 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 


10 

20 

30 


31 

32 

34 

36 

38 


SUBROUTINE BESJ 
PURPOSE 

COMPUTE THE J BESSEL FUNCTION FOR A GIVEN ARHUMENT AND 
USAGE 

CALL BESJ(X,N, BJ ,D, IER) 

DESCRIPTION OF PARAMETERS 

X -THE ARGUMENT OF THE J BESSEL FUNCTION DESIRED 
N -THE ORDER OF THE J BESSEL FUNCTION DESIRED 
BJ -THE RESULTANT J BESSEL FUNCTION 
D -REQUIRED ACCURACY 
IER-RESULTANT ERROR CODE WHERE, 

IER-0 NO ERROR 

IER-1 N IS NEGATIVE 

IER-2 X IS NEGATIVE OR ZERO 

IER-3 REQUIRED ACCURACY NOT OBTAINED 

IER-4 RANGE OF N COMPARED TO X NOT CORRECT (SEE R 

REMARKS 

N MUST BE GREATER THAN OR EQUAL TO ZERO, BUT IT MUST B 
LESS THAN 

20+10*X-X** 2/3 FOR X LESS THAN OR EQUAL TO 15 
90+X/2 FOR X GREATER THAN 15 

SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED 
NONE 

METHOD 

RECURRENCE RELATION TECHNIQUE DESCRI3ED BY H. GOLDSTEI 
R.M. THALER, 'RECURRENCE TECHNIQUES FOR THE CALCULATION 
BESSEL FUNCTIONS' ,M.T. A. C. ,V. 13, PP. 102-108 AND I. A. ST 
AND M. ABRAMOWITZ, 'GENERATION OF BESSEL FUNCTIONS ON H 
SPEED COMPUTERS' ,M.T. A. C. ,V . 11 , 1957 , PP. 255-257 


SUBROUTINE BESJ(X,N,BJ,D,IER) 
BJ“. 0 

IF(N)10,20,20 

IER=l 

RETURN 

IF(X)30, 30,31 

IER=2 

RETURN 

IF(X-15.)32, 32,34 
NTEST“20.+10.*X-(X**(2/3)) 

GO TO 36 
NTEST-90.+X/2. 

IF(N-NTEST)40, 38, 38 

IER-4 

RETURN 
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0058 

40 

IER-0 

0059 


Ni-N+l 

0060 


BPREV-O. 

0061 

C 


0062 

C 

COMPUTE STARTINC VALUE OF M 

0063 

C 


0064 


IF(X-5. >50,60,60 

0065 

50 

MA-X+6. 

0066 


CO TO 70 

0067 

60 

MA«1.4*X+60./X 

0068 

70 

MB-N+IFIX(X)/4+2 

0069 


flZF.RO-MAXO(MA,MB) 

0070 

C 


0071 

c 

SET UPPER LIMIT OF M 

0072 

c 


0073 


MMAX-NTEST 

0074 

100 

DO 190 M-MZER0.MMAX.3 

0075 

c 


0076 

c 

SET F(M),F(M-1) 

0077 

c 


0078 


FMi-i.OE-28 

0079 


FM-.O 

0080 


ALPHA-. 0 

0081 


IF(M-(M/2)*2)120, 110,120 

0082 

no 

JT— 1. 

0083 


CO TO 130 

0084 

120 

JT-i. 

0085 

130 

M2-M-2 

0086 


DO 160 K«1,M2 

0087 


MK-M-K 

^88 


BMK-2.*FL0AT(MK)*FM1/X-FM 

0089 


FM-FM1 

0090 


FMi-BMK 

0091 


IF(MK-N-i. >150,140,150 

0092 

140 

BJ-BMK 

0093 

150 

JT— JT 

0094 


S-l+JT 

0095 

160 

ALPHA -ALPHA +BMK*S 

0096 


BMK-2.*FM1/X-FM 

0097 


IF(M)180, ’.70,180 

0098 

170 

BJ-BMK 

0099 

180 

A LPHA-ALPHA+BMK 

0100 


BJ-BJ /ALPHA 

0101 


IF(ABS(BJ-BPREV)-ABS(D*BJ ) >200, 200, 190 

0102 

190 

BPREV-BJ 

0103 


IER-3 

0104 

200 

RETURN 

0105 


END 

0106 

$ 



# 
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&BLDWF T *00004 IS ON CR00022 USING 00022 BLKS R-4I13 

0001 FTN4 

0002 PROGRAM BLDWF 

0003 C 

0004 C 

0005 C THIS PROGRAM IS USED IN CONJUNCTION WITH IMAGE PROCESSING 

0006 C IT CREATES AND MAINTAINS AN IMAGE WORK FILE WITH PIXEL VALUES 

0007 C STORED AS REAL NUMBERS TO PRESERVE PRECISION. 

0008 C 

0009 C 

0010 C 

0011 C 

0012 DIMENSION IDCB1(272) ,IDCB2( 1040) , IDCB3( 528) , IMAGE (6) ,LU(5) 

0013 DIMENSION IRTN( 5) ,JNAME( 3) , IBUF( 15) ,RDATA( 512) ,IDATA(512) , 

0014 1 ISIZE(2) 

0015 C 

0016 EQUIVALENCE ( ILINE , IRTN( 4 ) ) , ( IPIXL , IRTN( 5 ) ) , ( ILINE , RDATA ) , 

0017 1 (RDATA ( 2) , RMAX) , (RDATA( 3) , RMIN) , ( IBUF ( 12) , ILOC) , (IBUF( 13) , JN 

0018 EQUIVALENCE ( IBUF(7 ) ,NI 1NE) , (IBUF(8) ,NPIXL) , (IBUF (9) , IPMIN) , 

0019 l (IBUF(IO) , IPMAX) , (IS1ZE(2),TSIZ2I 

0020 C 

0021 C 

0022 C 

0023 C 

0024 C GET INPUT PARAMETERS 

0025 C 

0026 CALL RMPAR(LU) 

0027 IF (LU .LE. 0) LU - 1 

0028 C 

0029 C REUSE WORK FILE 

0030 C 

0031 WRITE(LU, 7) 

0032 7 FORMAT(// , "DO YOU WANT TO REUSE THE CURRENT WORK FILE? Y OR 

0033 READ(LU, 2) IANS 

0034 IF ( IANS .EQ. 1HY )C0 TO 200 

0035 C GET IMAGE NAME FROM USER 

0036 C 

0037 WRITE(LU.l) 

0038 1 FORMAT ("ENTER IMAGE NAME (12 CHARACTER)? ") 

0039 READ(LU, 2) IMAGE ~ 

0040 2 FORMAT(6A2) 

0041 C 

0042 C CHECK IF WORK FILE WANTED 

0043 C 

0044 IF ( ICMPW( IMAGE, 12H ,6) .EQ. 0) GO TO 140 

0045 C 

0046 C OPEN DIRECTORY Fl_.. 

0047 C 

0048 90 CALL 0PEN(IDCB1 , IERR, 6HIMDIRC, 1 , 2HIM, 23 , 272 ) 

0049 IF (IERR .LT. 0) GO TO 9999 
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0051 

0052 

0053 

0054 

0055 

0056 

0057 

0058 

0059 

0060 
0061 
0062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 
0073 

0079 

0080 
0081 
0082 

0083 

0084 

0085 

0086 

0087 

0088 

0089 

0090 

0091 

0092 

0093 

0094 

0095 

0096 

0097 

0098 

0099 

0100 
0101 
0102 

0103 

0104 

0105 

0106 

0107 

0108 
0109 


C FIND IMAGE 
C 

100 CALL READF(IDCB1,IERR,IBUF,15,LEN) 

IF (IERR .LT. 0 ) GO TO 9999 
IF (LEN .EQ. -I) GO TO 9990 
C 

IF ( ICMPW ( IMAGE , IBUF , 6 ) .NE. 0) GO TO 100 
C 

C IMAGE FOUND 

C 

C 

IF (ILOC . 'E, 1) GO TO 9980 
C 

C IMAGE IS ON DISC 
C 

C CREATE WORK FILE 
C 

CALL OPEN( IDCB2 , IERP , 6HWF0000) 

IF (IERR .EQ. -6) GO TO 110 
IF (IERR .LT. 0) GO TO 9999 
C 

C ASK IF USER WANTS TO SAVE WORK FILE 
C 

WRITE(LU, 6) 

6 FORMAT(" DO YOU WANT TO SAVE IMAGE IN CURRENT WORK FILE?_") 
READ(LU, 2) IANS 
IF (IANS .EQ. 2HN0) GO TO 110 
C 

C SCHEDULE BUILD IMAGE PROGRAM 
C 

CALL CL0SE(IDCB2) 

CALL EXEC( 23 , 6HBLDIM ,LU) 

C 

110 CALL PURGE(IDCB2 ,IERR, 6HWF0000) 

IF (NPIXL .LT. 3) NPIXL - 3 

ISIZE = (2 .0*FL0AT(NLINE+1 )*FL0AT(NPIXL)+127 . ) / 128 . 

ISIZ2 =■ 2*NPIXL 

CALL CREAT(IDCB2, IERR, 6HWrOOOO, ISIZE, 2, 0,0, 1040) 

’F (IERR .LT. 0) GO TO 9999 

C 

C OPEN IMAGE DATA FILE 
C 

CALL OPEN( IDCB3 , IERR, JNAME , 1 , 2HIM ,23,528) 

IF (IERR .LT. 0) GO TO 9999 
C 

C COPY DATA AND CONVERT TO REAL 
C 

C POSITION TO RECORD 9 2 
C 

CALL WRITF(IDCB2,IERR,RDATA, 1) 

C 

DO 120 I=»l ,NLINE 

CALL READF( IDCB3, IERR, IDA TA, 512, LEN) 

IF (IERR .LT. 0) GO TO 9999 
C 

DO 115 J-l, NPIXL 
115 RDATA(J) ■» IDATA(J) 

C 

CALL WRITF ( IDCB2 . IERR, RDATA ) 


0110 

0111 

0112 

0113 

0114 

0115 

0116 

0117 

0118 

0119 

0120 
0121 
0122 

0123 

0124 

0125 

0126 


120 

C 


IF (IERR 
CONTINUE 


.LT. J) CO TO 9999 


RPMAX 

RPMT.N 


- IPMAX 

- IPMIN 


C 

C CLOSE ALL IMAGE FILES 
C 

130 


C 

C 

C 


CALL CLOSE(IDCBl) 

CALL CL0SE(IDCB3) 

WRITE INFO IN WORK FILE RECORD 1 

ILINE - NLINE 
IPIXL - NPIXL 
RMAX - RPMAX 
RMIN - RPMIN 


0127 

0128 

0129 

0130 

0131 

0132 

0133 

0134 

0135 

0136 

0137 

0138 

0139 

0140 

0141 

0142 

0143 

0144 


CALL WRITF(IDCB2, IERR, RDATA, 6,1) 
IF (IERR .LT. 0) GO TO 9999 
C 

CALL CL0SE(IDCB2) 

C 

140 IRTN - 0 

200 CALL PRTN(IRTN) 

CALL EXEC(6) 

C 

C ERRORS 

C 

C 

C IMAGE NOT ON DISC 
C 

9980 WRITE(LU ,4) 

4 FORMATC' IMAGE NOT ON DISC!") 
IRTN - -100 
GO TO 200 


0145 

0146 

0147 

0148 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158 

0159 

0160 
0161 


C 

C IMAGE NOT FOUND 
C 

9990 WRITE(LU, 3) 

3 FORMAT(" IMAGE NOT FOUND!") 

IRTN - -101 
GO TO 200 
C 

C FILE ERROR 
C 

9999 WRITE(LU, 5) IERR 
5 FORMAT( "FILE ERROR =*",I6) 

201 IF(IERR.EQ.-8) CALL CLOSE( IDCBl , IERR) 
IRTN - -103 
GO TO 200 
END 


$ 


aSCWL r =0000-4 IS ON CR00022 USING OOOOO 8LXS K=0050 


100 


0001 FTN4 

0002 INTEGER FUNCTION SCROL( IDCB, IDIRC, NLINE , IFRST, HAST, RMAX,RMI 

0003 C 

0004 C THIS SUBROUTINE IS USED TO SCROLL AN IMAGE ON THE GMR-27 

0005 C 

0006 C IDCB - OPENED DATA CONTROL BLOCK FOR THE IMAGE 

0007 C IDIRC - DIRECTION TO SCROLL (-N- BACK N LINES N- FORWARD N LI 

0008 C NLINE - If LINES IN IMAGE 

0009 C IFRST - LOWEST IMAGE LINE DISPLAYED 

0010 C IL\ST - HIGHEST IMAGE LINE DISPLAYED 

OOU C 

0012 C 

0013 DIMENSION IDCB(144),IDATA(512) 

0014 C 

0015 INTEGER SCROL 

0016 C 

0017 DATA IUP, ID0WN/34060B,34040B/ 

0018 C 

0019 C CHECK IF NO WORK NECESSARY 

0020 C 

0021 IF V IDIRC .EQ. 0) RETURN 

0022 C 

0023 IF (IDIRC .GT. 0) GO TO 200 

0024 C 

0025 C SCROLL IMAGE UP 

0026 C 

0027 

0028 

0029 

0030 C 

0031 

0032 

0033 

0034 

0035 110 

0036 C 
C037 
0033 

0039 

0040 

0041 100 

0042 

0043 C 


0044 

C SCROLL IMAGE DOWN 

0045 

C 


0046 

200 

DO 210 1=1, IDIRC 

0047 


IF (HAST .GE. NLINE-1 ) RETURN 

0048 


CALL READF( IDCB , SCROL , IDATA , 512 , LEN, ILAST+1 ) 

0049 

C 


0050 


DO 220 J=1 ,LEN 

0051 


IDATA(J) = (255. /(RMAX-RMIN) )>'(IDATA(J)-RMIN) 

0052 


IF (IDATA(J) .LT. 0) IDATA(J) = 0 

0053 


IF (IDATA(J) .GT. 255) I DATA ( J ) = 255 

0054 

220 

CONTINUE 

0055 

C 


0056 


IF (SCROL .LT. 0) RETURN 

0057 


CALL DRIVR(2,ID0WN, 1) 

0058 


CALL WLINE(255,0,LEN-1, IDATA) 

0059 


I LAST - IIAST+1 

0060 

210 

IFRST = IFRST+l 

0061 

C 


0062 


RETURN 

0063 


END 


DO 100 I— 1, IDIRC, -1 
IF (IFRST .LE. 0) RETURN 

CALL READF( IDCB, SCROL, IDA TA, 512, LEN, IFRST) 

DO 110 J-l.LEN 

IDATA(J) - (255. / (RMAX-RMIN) )*(IDATA( J)-RMIN) 
IF (IDATA(J) .LT. 0) IDATA(J) = 0 
IF (IDATA(J) .GT. 255) IDATA(J) - 255 
CONTINUE 

IF (SCROL .LT. 0) RETURN 

CALL DRIVR(2,IUP,n 

CALL WLINE(0,0,LEN-1 ,IDATA) 

IFRST - IFRST- 1 
I LA ST - I LAST-1 
RETURN 


&WLINE T-00004 IS ON CR00022 USING 00005 BLKS R-0036 


0001 FTN4,L 

0002 SUBROUTINE WLINE(LINE, IPIX, JPIX, IDATA) 

0003 C 

0004 C THIS SUBROUTINE WRITES A DESIGNATED LINE TO THE GMR-27 

0005 C 

0006 C LINE - LINE NUMBER 

0007 C IPIX - STARTING PIXEL 

0008 C JPIX ■ ENDING PIXEL 

0009 C IDATA - BUFFER CONTAINING IMAGE DATA FOR LINE 

0010 C 

0011 C 

0012 DIMENSION IDATA(512) ,INIT(6) 

0013 C 

0014 EQUIVALENCE (LLA ,INIT(2) ) , (LEA ,INIT(3) ) , (LEB, INIT(4) ) 

0015 C 

0016 DATA INIT/100377B,64000B,44000B, 50000B, 24041B, 26002B/ 

0017 C 

0013 C COMPUTE DIRECTION 

0019 C 

0020 IDIRC - 1 

0021 IF (IPIX .GT. JPIX) IDIRC - -1 

0022 C 

0023 C SET UP TO WRITE LINE 

0024 C 

0025 LLA - 64000B + IAND(LINE, 3773) 

0026 LEA * 44000B + IAND(IPIX, 777B) 

0027 LEB - 50000B + IDIRC + 512 

0023 CALL DRIVR(2,INIT,6) 

0029 C 

0030 C WRITE LINE 

0031 C 

0032 NUM - IDIRC*(JPIX-IPIX)+1 

0033 CALL DRI VR( 2 , I DATA , NUM) 

0034 C 

0035 RETURN 

0036 END 

0037 $ 


102 


&DRIVR T-00004 IS ON CR00022 USING 00012 BLKS R-0241 

ASMB,R,L,C 

NAM DRIVR, 6 
ENT DRIVR 

EXT .ENTR,$LIBR,$LIBX 


0001 
0002 

0003 

0004 

0005 * 

0006 * 

0007 OPCOD BSS 1 
0003 BUFR BSS 1 


0009 

LEN 

BSS 

1 

0010 

A* 



0011 

DRIVR NOP 


0012 


JSB 

.ENTR 

0013 


DEF 

OPCOD 

0014 


LDA 

LEN, I 

0015 


CMA, 

, INA 

0016 


STA 

CNT 

0017 


SS\, 

, RSS 

0013 


JMP 

EXIT 

0019 

* 



0020 


JSB 

$LIBR 

0021 


SOP 


0022 


LDA 

OPCOD, 1 

0023 


SLA , 

ELA 

0024 


JMP 

D.2 

0025 

* 



0026 

* 

WRITE REQUEST 

0027 

* 



0028 


SSA , 

, RSS 

0029 


JMP 

D.l 

0030 

* 



0031 

* 

DMA OUTPUT 

0032 

* 



0033 


LDA 

CW1 

0034 


OTA 

DMA 2 

0035 


CLC 

3B 

0036 


LDA 

BUFR 

0037 


OTA 

3B 

0033 


STC 

3B 

0039 


LDA 

CNT 

0040 


OTA 

3B 

0041 


LDA 

BUFR, I 

0042 


OTA 

SC 

0043 


STC 

SC,C 

0044 


STC 

DMA 2 , C 

0045 


SFS 

DMA2 

0046 


JMP 

*-l 

0047 


CLF 

DMA 2 

0048 


JMP 

EXIT+1 

0049 

* 



0050 

* 




ENTRY 

GET 

PARAMETERS. 

GET 9 WORDS 
NEGATE 
& SAVE. 

IF NOT NEGATIVE 
EXIT 

TURN OFF 
INTERRUPTS. 
CHECK REQUEST 
IF READ 
GO PROCESS 


IF DMA NOT REQUIRED 
GO DO PROGRAMMED I 0 


GET CONTROL WORD I 
USE CRANNEL 2 
PREPARE TO SEND ADDRESS 


PREPARE TO SEND COUNT 


START DEVICE 
START DMA 
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0051 

D.l 

LDA BUFR.I 

GET DATA WORD 

0052 


OTA SC 

OUTPUT IT. 

0053 


STC SC,C 

TURN ON DEVICE 

0054 


SFS SC 

WAIT 'TIL 

0055 


JMP *-l 

DONE 

0056 


ISZ BUFR 

BUMP BUFFER ADDRESS 

0057 


ISZ CNT 

LAST WORD? 

0058 


JMP D.l 

NO GO BACK. 

0059 


JMP EXIT 

GO EXIT 

0060 

* 



0061 

* READ ENTRY 


0062 

* 



0063 

D.2 

SSA 

SKIP IF SPECIAL 

0064 


JMP D.3 

MODE 

0065 


LDA SPD8 

SET UP 

0066 


OTA SC 


0067 


STC SC,C 

FOR 

0068 


SFS SC 


0069 


JMP *-l 

READ. 

0070 

D. 3 

LDA RDPD 

GET READ DATA CODE 

0071 


OTA SC 


0072 


STC SC,C 

START DEVICE 

0073 


SFS SC 

WAIT 'TIL 

0074 


JMP *-l 


0075 

D.4 

LDA RDPD 


0076 


on sc 


0077 


STC SC,C 


0078 


SFS SC 


0079 


JMP *-l 


0080 


LIA SC 

DONE. GET WORD. 

0081 


STA BUFR.I 

STUFF IN BUFFER 

0082 


ISZ BUFR 

BUMP BUFFER 

0083 


ISZ CNT 

DONE? 

0084 


JMP D.4 

NO GO BACK. 

0085 

* 



0086 

EXIT 

CLC SC 

TURN OFF DEVICE 

0087 


JSB $LIBX 

RESTORE RTE AND 

0088 


DEF DRIVR 

RETURN 

0089 

* 



0090 

* 



0091 

* 



0092 

A 

EQU 0 


0093 

* 



0094 

SC 

EQU 22B 


0095 

RDPD 

OCT 160000 


0096 

SPD8 

OCT 120400 


0097 

CNT 

BSS 1 


0098 

CW1 

OCT 120022 

* HAVE TO CHANGE WITH SELECT CODE 

0099 

DMA 2 

EQU 7 


0100 


END 



&FDIG1 T-000U4 IS ON CR00022 USING 00018 BLKS R-0132 


0001 

FTN4.L 

0002 


SUBROUTINE ROTAE(U,V,MN,LU) 

0003 


COMPLEX P(10),Q(10),QQ,PP 

0004 


DIMENSION U(3, 3, 2) ,V(3,3, 2) 

0005 


COMMON/WORK/AMAG( 10) ,A( 3 , 3) , B( 3 , 3) 

0006 


WRITE(LU.IOO) 

0007 

100 

FORMAT (“ SELECT FILTER 1. BUTTERWORTH 

0008 


1 "2. CHEBYSHEV 3. LINEAR PHASE ”/) 

0009 


READ(LU,*) ITYPE 

0010 


WRITE(LU.llO) 

0011 

110 

FORMATC* ENTER THE NUMBER OF FILTER STAGES ”/) 

0012 


READ(LU,*) NSTG 

0013 


WRITE(LU, 120) 

0014 

120 

FORMATC’ ENTER RELATIVE CUTOFF FREQUENCY FOR LOWPASS ’’/) 

0015 


READ(LU,*) WR 

0016 


WRITE(LU, 140) 

0017 

140 

FORMATC’ ARE ALL ZEROS LOCATED AT INFINITY 

0018 


1 ” 1 - YES •’/,•’ 2 - NO "/) 

0019 


READ(LU, *) IFLAG 

0020 


WRITE(LU, 151 ) 

0021 

151 

FORMATC’ ENTER RIPPLE FACTOR ’’/) 

0022 


READ(LU,*) ELP 

0023 

C 


0024 

C 

IF ( ITYPE. EQ. 1) CALL BUTTER 

0025 


IF( ITYPE. EQ. 2) CALL CHEBl(NSTG,WR, P,AMAG,ELP) 

0026 

C 

IF(ITYPE.EQ. 3) CALL LINEAR PHASE 

0027 

C 


0023 

20 

DO 10 J“l,NSTG 

0029 

30 

WRITE(LU, 130) J 

0030 

130 

FORMATC* ENTER ROTATION ANGLE IN NEG. DEGREES FOR STAGE 

0031 


1,12/) 

0032 


READ(LU,*) THETA 

0033 

C 


0034 


PMAG - AMAG(J) 

0035 


Q(J) - CMPLX(-1. ,0.) 

0036 


QQ - Q(J) 

0037 


PP » P(J) 

0038 


CALL SROTT(A , B , PMAG , PP , QQ , IFLAG , THETA ) 

0039 


DO lill 1-1,3 

0040 


DO lltl K-1,3 

0041 


U(I,K,J) - A(I,K) 

0042 

mi 

V(I,K,J) - B(I,K) 

0043 


WRITE(LU, 40) P(J),AMAG(J) 

0044 

40 

F0RMAT(IX,1(’’ P-" , 1E15. 5, ” +J" , IE15. 5, /) , ” PMAG= ”,Ei5. 

0045 

10 

CONTINUE 

0046 


MN - NSTG + 1 

0047 


WRITE(i ,1112) U 

0048 


WRITE( l , 1112) V 

0049 

1112 

FORMAT(3E15.4) 

0050 


RETURN 

0051 


END 


105 


0052 

SUBROUTINE CHEBi(N,WR,P,AMAG,ELP) 

0053 

DIMENSION AMAG(N) 

0054 

COMPLEX P(N),PN 

0055 

PI-3.1415927 

0056 

E-l.O/ELP 

0057 

SINHIV-ALOG(E+SQRT(E**2+l . 0) ) 

0058 

ALP-( -1 . 0*S INHIV ) /FLOAT ( N ) 

0059 

IF(WR.EQ.l.O) GO TO 30 

0060 

X-O. 5*WR*PI 

0061 

IF(COS(X) .EQ.O.O) GOTO 30 

0062 

XTAN-SIN(X)/COS(X) 

0063 

KK-l 

0064 

NTWO-4*N 

0065 

XX- 1 • 0/FLOAT(NTWO) 

0066 

DO 20 1-1 ,NTWO 

0067 

GAMMA-( 2*1-1 )*PI*XX 

0068 

Ci-(EXP( ALP)-EXP(-ALP))/2. 

0069 

C2-SIN( GAMMA) 

0070 

C3-(EXP( ALP)+EXP(-ALP))/2. 

0071 

C4-COS( GAMMA) 

0072 

XR-Ci*C2 

0073 

XI-C3*C4 

0074 

PN-XTAN*CMPLX(XR,XI) 

0075 

IF(REAL(PN) .GT.O.O) GO TO 20 

0076 

IF(AIMAG(PN) .LT.O.O) GO TO 20 

0077 

P(KK)-PN 

0078 

AMAG(KK)-CABS(PN)**2 

0079 20 

KK-KK+1 

0080 

GO TO 34 

0081 30 

WRITE(LU, 33) 

0082 33 

FORMAT ( " CUTOFF FREQ. CAN NOT - 

0083 34 

RETURN 

0084 

END 
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0085 

ooe6 

0087 

0088 

0089 

0090 

0091 

0092 

0093 

0094 

0095 

0096 

0097 

0098 
009 ^ 
01C / 
0101 
0102 

0103 

0104 

0105 

0106 

0107 

0108 

0109 

0110 
0111 
0112 

0113 

0114 

0115 

0116 

0117 

0118 

0119 

0120 
0121 
0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 

0132 

0133 

0134 

0135 

0136 

0137 

0138 


S UB ROUTINE SROTT (A , B , PMAG , PP,QQ, IFLAG. THETA ) 
DIMENSION A(3,3) ,B(3,3) 

COMPLEX PP.QQ 

ADJ-0.999 

X -THETA *0.0174533 

C1«C0S(X)**2 

C2- , ’.0*COS(X)*SIN(X) 

C3=S1N(X)**2 

C7 — 2.0*REAL(PP)*C0S(X) 

C8=2.0*REAL(PP)*SIN(X) 

C9«CABS(PP)**2 

B( 1 , 1 )-C1+C2+C3-k;7+C8+C9 

B ( l , 2 ) -2 . 0* ( C l -C3+C7+C9) *AD J 

B( 1 , 3)=(Cl-C2+C3+C7-C8+C9)*ADJ**2 

B( 2 , 1 )-•> . 0*( C3-Cl+C8+C9)*ADJ 

B(2,2)=4.0*(C9-C1-C3)*ADJ**2 

B(2,3)=2.0*(C3-C1-C8+C9)*ADJ**3 

B( 3 , 1 )»(C1-C2+C3-C74C8+C9)*ADJ**2 

B(3, 2)=2. 0*(C1-C3-C7+C9)*ADJ**3 

B(3,3)»(C1+C2+C3-C7-C8+C9)*ADJ**4 

IF( IFLAG. EQ.l) Gj TO 10 

C4=-2.0*REAL(QQ)*COS(X) 

C5=2 . 0*REAL(QQ)*SIN(X) 

C6=CABS(QQ)**2 
A ( 1 , 1)-C1+C2+C34-C4+C5+C6 
A ( 1 , 2 ) -2 . 0* ( C 1- -C3+C4+C6 ) 

A( 1 , 3)=C1-C2+C3+C4-C5+C6 
A( 2 , 1 )=2. 0*(C3-C1+C5+C6) 
A(2,2)=4.0*(C6-C1-C3) 

A( 2 , 3)=2 . 0*(C3-C1-C5+C6) 

A ( 3 , 1 )=C1-C2+C3-C4+C5+C6 
A(3,2)»2.0*(C1-C3-C4+C5+C6) 

A ( 3 , 3)»C1+C2+C3-C4-C5+C6 
GO TO 20 

10 A(l,l)-1.0 

A (l, 2) =2.0 
A( l , 3)=1 . 0 
A(2,l)=2.0 
A( 2 , 2)»4. 0 
A ( 2 , 3 ) =2 . 0 
A( 3 , 1 )=1 . 0 
A(3, 2)=2.0 
A( 3 , 3)=1 . 0 
20 CONTINUE 

SCAL = l . /B( l , 1 ) 

DO 30 1=1,3 
DO 30 K=1 , 3 

B(I,K)=( B( I , K)*SCAL) 
A(I,K)=(A(I,K)*SCAL*PMAG) 

30 CONTINUE 

RETURN 
END 

$ 

$ 
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& STAB I T-00004 IS ON CR00022 USING 00070 BLKS R-0G68 


0001 

FTN4, 

L 

0002 



PROGRAM STAFT 

0003 

C 



0004 

C 

THIS PROGRAM EVALUATES THE FILTER STABILITY CHARACTERISTICS 

0005 

C 



0006 

C 



0007 



COMMON/WORK/WO (130) 

0008 

C 


INTEGER BUFF 

0009 



DIMENSION IBUF(80) , I LU( 5 ) , IRTN( 5 ) 

0010 



DIMENSION V(3,3,2),U(3,3,2) 

0011 



EQUIVALENCE ( IBUF( 1 ) ,U(1 , 1 , 1 ) ) , (1BUF(41 ) , V( 1 , 1 , 1) ) 

0012 

C 



0013 



CALL RMPAR(ILU) 

0014 



LU-ILU(l) 

0015 



MN=ILU( 2 ) + 1 

0016 

C 



0017 

C 



0013 

C 

GET 

FILTER COEFF'S 

0019 



CALL EXEC( 14,1, IBUF , 80) 

0020 

C 



0021 

C 



0022 



CALL STABT(V,MN,IRTCD,LU) 

0023 



IRTN = IRTCD 

0024 

C 



0025 



CALL PRTN(IRTN) 

0026 



END 

0027 



SUBROUTINE STABT(V,MN, IRTCD, LU) 

0023 

C 


SUBROUTINE CHECKS STABILITY OF SYSTEM EQUATICN- 

0029 

C 


Y(M,N)=A*Y(M-1,N)+B*Y(M,N-1) 

0030 

C 



0031 

c 


C COEFFICIENT MATRIX OF DENOMINATON OF ZW-TRANSFORM OF : 

0032 

c 


IMPULSE FUNCTION 

0033 

c 



0034 



LOGICAL ISTAB 

0035 



DIMENSION V(3,3,2) 

0036 



DIMENSION C(5,5),A(25,25),B(25,25),S(25,25) ,EVR(25) ,EVI(2 

0037 



COMMON/WORK/IERR( 25) 

0038 



MDIM=25 

0039 



N=2 y *(MN-l )+i 

0040 



M=N**2 

0041 



IF(MN.EQ.3) GO TO 5 

0042 

c 



0043 

c 


PUT COEFFICENTS IN STABILITY ARRAY 

0044 

c 



0045 



DO 6 1=1,3 

C046 



DO 6 J=1 , 3 

0047 


6 

C( I , J)=V(I, J , 1) 

0048 



GO TO 13 

0049 


5 

DO 10 1=1,5 

0050 



DO 10 J=1 , 5 

0051 



DO 10 K=1 , 3 

0052 



DO 10 L=1 , 3 

0053 



IK=I-K+1 

0054 



JL=J-L+1 

0055 



IF ( (IK .LE. 0) .OR. (IK .CT. 3)) GO TO 10 

0056 



IF( ( JL .LE. 0) .OR. (JL .GT. 3)) GO TO 10 

0057 



C(I, J)=C(I, J)+V(IK, JL , 1)*V(K,L, 2) 

0058 


10 

CONTINUE 
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0059 

C 



0060 


13 

CONTINUE 

0061 

U 


WRITE(LU, 11) 

0062 


11 

FORMAT (2 OHO COEFFICIENT MATRIX,/) 

0063 

C 


DO 21 I-1,N 

0C64 

c 

21 

WRIT£(LU, 12) (C(I,J),J-1,N),N 

0065 


12 

F0RMAT(1H , 5F15.6) 

0066 

c 



0067 

c 


FORM A AND B MATRICES 

0063 

c 



0069 



DO 22 I-1,M 

0070 



DO 22 J-l,M 

0071 



A(l, J)*0.0 

0072 



B( I , J)*0. 0 

0073 


22 

S(I,J)-0.0 

0074 



NNOW-N-l 

0075 



DO 23 J«1,N 

0076 



DO 23 I-l.MNOM 

0077 



R*I+(J-l)*N 

0073 



IF(J.EQ.l) GO TO 24 

0079 


24 

A( 1 ,K)*-C(I+1 , J) 

0080 



IF(J.GT.l) A(1,K)«- 0.5*C(I+l,J) 

0081 



IF(J.GT.l) A(K+1 ,K)*0. 5 

0082 



IF(J.EQ.I) A(K+1,K)-1.0 

0033 


23 

CONTINUE 

0034 



DO 25 J-l.NNOW 

0085 



DO 25 1*1 ,N 

0086 



K=I+( J-l )*N 

00S7 



KN=K+N 

0083 



IF(I.EQ.l) GO TO 26 

0089 


26 

3(l,K)— C(I, J+l) 

0090 



IF(I.GT.l) B( 1 ,K)*-0 . 5*C(I , J+l ) 

0091 



IF(I.GT.l) B(KN,K)=0. 5 

0092 



IF(I.EQ.l) B(KN,K)*1.0 

0093 


25 

CONTINUE 

0094 

c 



0095 

c 



0096 

c 


FIND EIGENVALUES OF A AND B 

0097 

c 



0093 



DO 27 1*1, M 

0099 



DO 27 J=I,M 

0100 


27 

S(I,J)=A(I,J) 

0101 



CALL RNAN(MDIM,M,S,EVR,EVI , IERR) 

0102 



WRITE(LU, 71) 

0103 


71 

F0RMAT(/, LOX, 19HEIGEN VALUES OF (A)) 

0104 

c 



0105 



TEST-1.0 

0106 



IONE*0 

0107 

c 



0103 



CALL PNTEV(EVR,EVI ,M,MDIM,TEST, IONE, 

0109 



IF ( ISTAB) GOTO 405 

0110 


o 

o 

vT 

FORMAT(" FILTER IS UNSTABLE! "/) 

0111 


401 

FORMAT (" FILTER IS STABLE"/) 

0112 

c 



0113 



DO 94 1*1, M 

0114 



DO 94 J«1,M 

0113 


94 

S(I,J)=0.0 

0116 



DO 28 1*1, M 

0117 



DO 23 J*1,M 

0118 


28 

S(I,J)*B(I,J) 


ISTAB,IERR,LU) 
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0119 


CALL RNAN(MDIM,M,S, EVR, EVI, IERR) 

0120 


WRITE(LU.72) 

0121 

72 

F0RMAT(/,10X,19IIEIGEN VALUES OF (B)) 

0122 


CALL PNTEV(EVR,EVI ,M,MDIM,TEST, 10ME, ISTAB , IERR, LU) 

0123 


IF ( ISTAR) COTO 405 

0124 

C 


0125 

C 

FIND EIGENVALUES OF A+B 

0126 

C 


0127 


DO 29 I«1,M 

0 1 2 S 


DO 29 J-1,M 

0129 

0130 

29 

S(I,J)=A(l,J)+B(I,J) 

0131 


CALL RNAN(MDIM,M,S , EVR, EVI , IERR) 

0132 


WRITE(LU, 73) 

C 1 3 3 

73 

FORMAT ( / , 10X, 21HEIGEN VALUES OF (A+B)) 

0134 


CALL PNTEV(EVR, EVI .M.MDIM, TEST, IONE, ISTAB , IERR, LU) 

0135 

405 

IF ( ISTAB) WRITE(LU, 400) 

0136 


IF( ISTAB) GO TO 404 

0137 


WRITE( LU, 401 ) 

0138 

404 

IRTCD - 0 

0139 


GO TO 500 

0140 

C 


0141 

c 

FIND EIGENVALUES OF A*S 

0142 

c 


0143 


DO 30 1 = 1, M 

0144 


DO 30 J = 1 ,M 

0145 

30 

S(I,J)=0.0 

0146 


DO 31 I-1,N 

0147 


DO 31 J«l,N 

0148 


K=J+(I-1)*N 

0149 


L=I+( J-l )*N 

0150 

31 

S(K,L)=1 .0 

0151 


CALL MLTMX(A ,S,M,MDIM) 

0152 


CALL RNAN ( MD IM , M , S , EVR , EVI , IERR) 

0153 


WRITE( LU, 74) 

0154 

74 

FORMAT( /, 10X, 21HEIGEN VALUES OF (A*S)) 

0155 

C 


0156 


IONE=l 

0157 


TEST=0. 5 

0153 

c 


0159 


ICNT=0 

0160 


CALL PNTEV(EVR, EVI, M.MDIM, TEST, IONE, IST>\B, IERR, LU) 

0161 


IF (ISTAB) ICNT=1 

0162 


DO 230 1=1, M 

0163 


DO 230 J=1,M 

0164 

230 

S(I, J)=0.0 

0165 


DO 231 1=1, N 

0166 


DO 231 J=1 , N 

0167 


K=J+(I-1)*N 

0168 


L=I+( J-l )*N 

0169 

231 

S(K,L)=1.0 

0170 


CALL MLTMX(B,S, M.MDIM) 

0171 


CALL RNAN(MDIM,M,S, EVR, EVI, IERR) 

0172 


WRITE(LU, 75) 

0173 

75 

FORMAT(/ , 10X, 21HEIGEN VALUES OF (B*S)) 

0174 


C\LL PNTEV(EVR,EVI , M.MDIM, TEST, IONE, ISTAB, IERR, LU) 

0175 


IF( ISTAB) ICNT=ICNT+1 

0176 


IF( ICNT.EO. 2) v;R!TE(LU.401) 


no 


C177 

C 



0173 

C 

FIND EIGENVALUES OF ABS(A)-h\BS(B) 


0179 

C 



0180 


DO 33 I«l,M 


0131 


DO 33 J-l.M 


0132 

33 

S ( I , J ) -ABS (A ( I , J ) )+ABS ( B( I , J ) ) 


0183 


CALL RNAN(MDIM,M,S ,EVR, EVI , IERR) 


0184 


WRITE( LU, 76) 


0185 

76 

FORMAT( / , IOX, 29HEIGEN VALUES OF ABS(A)+ABS(B) ) 


01S6 

C 



0187 


TEST-1.0 


0133 

C 



0189 


CALL PNTEV(EVR, EVI, M.MDIM, TEST, IONE, ISTAB, IERR, LU) 


0190 


IF ( ISTAB) WRITE(LU,401) 


0191 

c 



0192 

c 

FIND EIGENVALUES OF A*B 


0193 

c 



0194 


CALL MLTMX(A,B, M.MDIM) 


0195 


CALL RNAN(MDIM,M,S,EVR, EVI, IERR) 


0196 


WRITE(LU, 77) 


0197 

77 

FORMAT( / , IOX, 21HEIGEN VALUES OF (A*B) ) 


0193 


CALL PNTEV(EVR, EVI, M.MDIM, TEST, IONE, ISTAB, IERR, LU) 


0199 


IF ( ISTAB) WRITE(LU, 401 ) 


0200 


GO TO 501 


0201 

500 

IF(ISTAB) IRTCD - 1000 


0202 

501 

RETURN 


0203 


END 


0204 


SUBROUTINE PNT2V(EVR, EVI , M.MDIM, TEST, IONE, ISTAB, IERR, LU) 

0205 


LOGICAL ISTAB 


0206 


DIMENSION EVR(MDIM) .EVI(MDIM) , IERR(MDIM) 


0207 

C 



0203 


ISTAB**. FALSE. 


0209 


D=1 . 0E-20 


0210 


RMX=0. 0 


0211 


DO 20 I=*l ,M 


0212 


R**EVR( I )**2+EVI( I )**2 


0213 


R=SQRT(R) 


0214 


RMX=AMA X 1 ( RMX , R ) 


0215 


IF(R.LT.D) GO TO 20 


0216 


IF ( IERR( I ) .LT. 0) WRITE(LU, 93) I,IERR(I) 


0217 

20 

CONTINUE 


0213 


WRITE( LU, 30) RMX 


0219 

C 



0220 


IF ( IONE . EQ . 0 .AND . RMX . GE .TEST) I STA B= . TRUE . 


0221 


IF ( IONE. EQ.l. AND. RMX. LE. TEST) ISTAB= .TRUE . 


0222 

10 

F0RMAT(1H ,E14. 7, 4X, 2H+J ,E14 . 7) 


0223 

11 

FORMAT ( 1311 ABS(LMDA) ■* ,E14.7) 


0224 

3C 

F0RMAT( 19H SPECTRAL RADIUS = ,E14.7/) 


0225 

93 

FORMAT( / / , IOX, "IERR( " ,12 , " ) *= ",I2/) 


0226 


RETURN 


0227 


END 


0223 


SUBROUTINE RNAN(N, M.S.EVR, EVI , IERR) 


0229 

C 

SUBROUTINE WAS WRITTEN TO CALL HSBG AND ATEIG IBM 

SCIENTIFIC 

0230 

C 

SUBROUTINES TO CALCULATE THE EIGENVALUES OF A 

REAL MATR 

0231 

C 

M ORDER OF THE FATRIX S 


0232 

C 

N SIZE OF FIRST DIMENSION ASSIGNED TO THE ARRAY 

S IN THE 

0233 

C 

CALLING PROGRAM 



0234 C 
0233 

0236 

0237 

0238 

0239 

0240 

0241 C 

0242 C 
024 3 C 

0244 C 

0245 C 

0246 C 

0247 C 

0248 C 

0249 C 

0250 C 

0251 C 

0252 C 

0253 C 

0254 C 

0255 C 

0256 C 

0257 C 
0253 C 

0259 C 

0260 C 

0261 C 

0262 C 

0263 C 

0264 C 

0265 C 

0266 C 

0267 C 

0268 C 

0269 C 

0270 C 

0271 C 

0272 C 

0273 C 

0274 C 

0275 C 

0276 C 

0277 C 
0273 C 
0279 C 
0200 C 
0281 
0282 
0283 
0204 C 
0285 
0206 
0287 
0283 
0289 


DIMENSION S(25,25),EVR(25).EVI(25) 

COMMON /WORK/ L\NA( 2 5 ) 

CALL HSBG(M,S,N) 

CALL ATEIC(M,S ,EVR,EVI , IANA , N) 

RETURN 

END 

SUBROUTINE ATEIG 
PURPOSE 

COMPUTE THE EIGENVALUES OF A REAL ALMOST TRIANGULAR MA 
USAGE 

CALL ATEIG(M,A ,RR, RI , IANA , IA ) 

DESCRIPTION OF THE PARAMETERS 
M ORDER OF THE MATRIX 

A THE INPUT MATRIX, M B7 M 

RR VECTOR CONTAINING THE REAL PARTS OF THE EIGENVA 
ON RETURN 

RI VECTOR CONTAINING THE IMAGINARY PARTS OF THE El 
VALUES ON RETURN 

IANA VECTOR WHOSE DIMENSION MUST BE GREATER THAN OR 
TO M, CONTAINING ON RETURN INDICATIONS ABOUT TH 
THE EIGENVALUES APPEARED (SEE MATH. DESCRIPTION 
IA SIZE OF THE FIRST DIMENSION ASSIGNED TO THE ARR 

IN THE CALLING PROGRAM WHEN THE MATRIX IS IN DO 
SUBSCRIPTED DATA STORAGE MODE. 

IA-M WHEN THE MATRIX IS IN SSP VECTOR STORAGE M 

REMARKS 

THE ORIGINAL MATRIX IS DESTROYED 

THE DIMENSION OF RR AND RI MUST BE GREATER OR EQUAL TO 

SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED 
NONE 

METHOD 

QR DOUBLE ITERATION 
REFERENCES 

J.G.F. FRANCIS - THE QR TRANSFORMATION— THE COMPUTER 
JOURNAL, VOL. 4, NO. 3, OCTOBER 1961, VOL 4, NO. 4, J 
1962. J. H. WILKINSON - THE ALCEBRAIC EI^NVALUE PROB 
CLARENDON PRESS, OXFORD, 1965. 


SUBROUTINE ATEIG(M ,A , RR, RI , IANA , IA ) 

DIMENSION A ( I ) , RR( 1 ) ,RI( l ) , PRR(2 ) , PRI(2) , IANA( I) 
INTEGER P,PI,Q 


E7=l .OE-8 
E6=l .OE-6 
E10=I . 0E-10 
DELTA -0.5 
MAXIT-30 


INITIALIZATION 


N=M 

20 NI-N-1 
IN=N1*IA 
NN-IN+N 

IF(N1) 30,1300,30 
30 NP=N+i 


ITERATION COUNTER 


ROOTS OF THE 2ND ORDER MAIN SUBMATRIX AT THE PREVIOUS 
ITERATION 

DO 40 1=1,2 
PRR(I)**0.0 
40 I'RI(I)-0.0 

LAST TWO SUBDIAGONAL ELEMENTS AT THE PREVIOUS ITERATION 

PAN’=0.0 
PAN 1=0 . 0 


ORIGIN SHIFT 


R=0.0 

S=0.0 

ROOTS OF THE LOWER MAIN 2 BY 2 SUBMATRIX 
N2=N1-1 

y '■ i=iH-iA 

NNl-IHl+H 
N1N=IN+N1 
N1N1=IN1+N1 
60 T=A(N1NL)-A(NN) 

U=T*T 

V = 4 . 0*A ( N 1 N ) *A ( NN 1 ) 

IF(ABS(V)-U*E7) 100,100,65 
65 T=U+V 

IF (ABS(T)-AMAXl (U, ABS( V) )*E6) 67,67,68 

67 T=0.0 

68 U=(A(N1N1 )+A(NN))/2.0 
V=SQRT(ARS(T) 3/2.0 

IF (T) 140, 70, 70 
70 IF(U) 80,75,75 
75 RR(N1 )=U+V 
RR(N)=U-V 
GO TO 130 
80 RR(N1)=U-V 
RR(N)=U+V 
GO TO 130 

100 IF(T)120, 110, 110 
110 RR(N1)=A(N1N1) 

RR(N)=A(NN) 

GO TO 130 


0349 


120 RR(Nl)-A(NN) 

0350 



RR(N)-A(N1NI) 

0351 


130 

RI(N)-0.0 

0352 



R I ( N 1 ) -0 . 0 

0353 



CO TO 160 

0354 

140 

RR(N1) - U 

0355 



RR(N)-U 

0356 



RI(Nl)-V 

0357 



RI(N)— V 

0358 


160 

IF(N2)128C, 1280, 180 

0359 

C 



0360 

C 


TESTS OF CONVERGENCE 

0361 

C 



0362 


180 

N1N2-N1N1-LY 

0363 



RM0D«RR(N1)*RR(N1)+RI(N1)*RI(N1) 

0364 



EPS-E10*SQRT(RM0D) 

0365 



IF(ABS(A(N1N2))-EPS) 1280, 1230, 240 

0366 


240 

IF (ABS(A (NN1 ) >-E10*ABS(A(NN) ) ) 1300, 1300,250 

0367 


250 

IF(ABS(PAN1-A(N1N2) )-ABS(A(NlN2) ) >V E6) 1240,1240,260 

0363 


260 

IF(ABS(PAN-A(NN1))-ABS(A(NN1))*E6> 1240, 1240, 300 

0369 


300 

IF( IT-MAXIT) 320,1240,1240 

0370 

C 



0371 

C 


COMPUTE THE SHIFT 

0372 

c 



0373 


320 

J = l 

0374 



DO 360 I - 1,2 

0375 



K-NP-I 

0376 



IF(ABS(RR(K)-PRR(I))+ABS(RI(K)-PRI(I ) )-DELTA*(ABS( RR(R) ) 

0377 


1 ' 1 S(RI(K) ) ) ) 340,360,360 

0373 


340 

J«J+I 

0379 


360 

CONTINUE 

0380 



GO TO (440, 460, 460, 480), J 

C381 


440 

R“0 . 0 

0382 



S=0.0 

03S3 



GO TO 500 

0384 


460 

J -N+2-J 

0385 



R=RR( J)*RR( J ) 

0386 



S=RR( J)+RR( J) 

0387 



Cl' TO 500 

0383 


480 

R=RR(N)*RR(N1)-RI(N) ,V RI(N1) 

0389 



S=RR(N)+RR(N1 ) 

0390 

c 



0391 

c 


SAVE THE LAST TWO SUBDIACONAL TERMS AND THE ROOTS OF THE 

0392 

c 


SUBMATRIX BEFORE ITERATION 

0393 

c 



C394 


500 

PAN-A ( NMl ) 

0393 



PA N l -A ( N 1 N 2 ) 

0396 



DO 520 1-1,2 

0397 



K-NP-I 

0393 



PRR( I )=RR( K) 

0399 


520 

PRI(1)=RI(K) 

0400 

c 



0401 

c 


SEARCH FOR A PARTITION OF THE MATRIX , DEFINED BY P AND Q 

0402 

c 



0403 



P=N2 

0404 



IF (N-3) 6 00, 600, 525 

0405 


525 

IPI=N1N2 

0406 



DO 580 J=2,N2 

0407 



IPI-IPI-IA-l 

0408 



IF(ABS(A( IPI) )-EPS) 600,600,530 

0409 


530 

IPIP-IPI+IA 


0410 

0411 

0412 

0413 

0414 

0415 

0416 

0417 
0413 

0419 

0420 

0421 

0422 

0423 

0424 

0425 

0426 

0427 
0423 

0429 

0430 

0431 

0432 

0433 

0434 

0435 

0436 

0437 
0433 

0439 

0440 

0441 

0442 

0443 

0444 

0445 

0446 

0447 
0443 

0449 

0450 

0451 

0452 

0453 

0454 

0455 

0456 

0457 

0458 

0459 

0460 

0461 

0462 

0463 

0464 

0465 

0466 

0467 

0468 

0469 


IPIP2-IPIP+IA 

D-A(IPIP)*(A(IPIP)-S)+A(IPIP2)*A(IPIP+1)+R 

IF(D)540,560,540 

540 IF(ABS(A(IPI)*A(IPIP+l))*(ABS(A(IPIP>-h\(IPIP2+l)-S)+ABS(A(IP 
l )) -ABS(D)*EPS) 620,620,560 
560 P-Nl-J 
580 CONTINUE 
600 Q-P 

GO TO 680 
620 r 1 -P-1 

q=pi 

IF (Pi-l) 680,680,650 
650 DO 660 1—2 , PI 
IPI-IPI-IA-1 

IF(ABS(A( IPI ) )-EPS)680, 680, 660 
660 Q=Q-1 
C 

C QR DOUBLE ITERATION 

C 

680 II«(P-i)*IA+P 
DO 1220 I=P ,N1 
IIi“II-IA 
IIP-II+IA 

IF(I-P)720,700,720 
700 IPI-II+l 
IPIP-IIP+1 
C 

C INITIALIZATION OF THE TRANSPORTATION 

C 

G1«A(II)*(A(II)-S)*A(IIP)"A(IPI)+R 
G2 =A ( I PI ) ,v (A ( I PI P )-h\ ( 1 1 ) -S ) 

G3=A(1PI)*A( IPIP+1 ) 

A( IPI+1 )=0.0 
GO TO 780 
720 G I =A (III) 

C2=A( IIl+l ) 

IF(I-N2)740,740,760 
740 C3=A(IIl+2) 

GO TO 780 
760 G3“0. 0 

780 CAP=SQRT(G1*C1+C2*G2+G3*C3) 

IF(CAP)800, 860, 800 
800 IF(G1 )820, 840, 840 
820 GAP— CAP 
340 T=G 1+CAP 
PSI 1=G2/T 
PSI2=G3/T 

ALP iiA — 2 .0/(1. 0+P51 1*PSI. i+P3I2*PSI2 ) 

GO TO 880 
860 ALPHA=2,0 
PSI1-0.0 
PSI2=0. 0 

880 IF( I-Q)900, 960, 900 
900 IF( I -P) 9 20, 940, 9 20 
920 A ( III )“-CAP 
CO TO 960 
940 A ( I I 1 ) =-A (III) 

C 

c 
c 


ROW OPERATION 


0470 

0471 

0472 

0473 

0474 

0475 

0476 

0477 
0473 

0479 

0480 

0481 

0482 

0483 

0484 

0485 

0486 

0487 

0488 

0489 

0490 

0491 

0492 

0493 

0494 

0495 

0496 

0497 
0493 

0499 

0500 

0501 

0502 

0503 

0504 

0505 

0506 

0507 

0508 

0509 

0510 

0511 

0512 

0513 

0514 

0515 

0516 

0517 
0513 

0519 

0520 

0521 

0522 

0523 

0524 

0525 

0526 


960 IJ-II 

DO 1040 J»I,N 
T>PSIi*A(IJ+i) 

IF(I-N1 >980,1000, 1000 
980 IP2J-IJ+2 

T-T+PSI2*A(IP2J) 

1000 ETA*ALPHA*(T+A( IJ>) 

A ( I J ) »A ( I J )-ETA 
A ( I J+l ) -A ( I J+i ) -PS I 1 *ETA 
IF(I-N1 >1020, 1040, 1040 
1020 A(IP2J)»A(IP2J)-P5I2*ETA 
1040 IJ-IJ+IA 
C 

C COLUMN OPERATION 

C 

IF(I-N1)1080, 1060, 1060 
1060 K=N 

GO TO 1100 
1080 K=I+2 
1100 IP=IIP-I 

DO 1180 J“Q,K 
JI?=IP+J 
JI=JI?-IA 
T=PSI1*A( JIP) 

IF(I-N1)1120, 1140, 1140 
1120 JIP2=JIP+IA 

T=T+P5I2*A( JIP2) 

1140 ETA=ALPHA*(T+A( JI) ) 

A( JI)»A( JI)-ETA 
A( JIP)“A( JIP)-ETA*PSIl 
IF(I-N1)1160, 1180, 1180 
1160 A( JIP2)=A( JIP2)-ETA*PSI2 
1180 CONTINUE 

IF( I-N2)1200, 1220, 1220 
1200 JI=II+3 
JIP=JI+L\ 

JIP2=JIP+IA 

ETA “ALPHA* PS I2*A(JIP2) 

A(JI)“-ETA 
A(JIP)“-ETA*PSIl 
A( JIP2)=A( JIP2)-ETA*PSI2 
1220 II=IIP+1 
IT=IT+i 
GO TO 60 
C 

C END OF ITERATION 

C 

1240 IF(ABS(A(NN1 ) )-ABS(A(NlN2) ) ) 1300,1280,1280 
C 

C TWO EIGENVALUES il\VE BEEN FOUND 

C 

1280 LANA (N)“0 
IANA(N1)“2 
N=N2 

IF(N2)1400, 1400,20 
C 
C 


ONE EIGENVALUE HAS BEEN FOUND 



0523 

0529 

0530 

0531 

0532 

0533 

0534 

0535 

0536 
053'/ 
0533 

0539 

0540 

0541 

0542 

0543 

0544 

0545 

0546 

0547 
0543 

0549 

0550 

0551 

0552 

0553 

0554 

0555 

0556 

0557 

0558 

0559 

0560 

0561 

0562 

0563 

0564 

0565 

0566 

0567 

0568 

0569 

0570 

0571 

0572 

0573 

0574 

0575 

0576 

0577 

0578 

0579 

0580 
0501 

0582 

0583 

0584 


C 

C 

C 

C 

C 

C 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 


1300 RR(N’)**A(NN) 

RI(N)“0.0 

IANA(N)-l 

IF(N1)1400, 1400, 1320 
1320 N-Nl 

GO TO 20 
1400 RETURN 
END 

SUBROUTINE HSBG 
PURPOSE 

TO REDUCE A REAL MATRIX INTO UPPER ALMOST TRIANGULAR F 
USAGE 

CALL HSBG(N,A,IA) 

DESCRIPTION OF THE PARAMETERS 
N ORDER OF THE MATRIX 

A THE INPUT MATRIX, N BY N 

IA SIZE OF THE FIRST DIMENSION ASSIGNED TO THE ARR 
A IN THE CALLING PROGRAM WHEN THE MATRIX IS IN 
DOUBLE SUBSCRIPTED DATA STORAGE MODE. IA-N WHE 
THE MATRIX IS IN SSP VECTOR STORAGE MODE. 

REMARKS 

THE HESSENBERG FORM REPLACES THE ORIGINAL MATRIX IN TH 
ARRAY A. 

SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED 
NONE 

METHOD 

SIMILARITY TRANSFORMATIONS USING ELEMENTARY ELIMINATIO 
MATRICES, WITH PARTLAL PIVOTING. 

REFERENCES 

f.H. WILKINSON - THE ALGEBRAIC EIGENVALUE PROBLEM - 
CLARENDON PRESS, OXFORD, 1965. 


C 

C 

C 


20 

40 


C 

C 

C 


SUBROUTINE HSBG(N,A , IA ) 

DIMENSION A ( 1 ) 

DOUBLE PRECISION S 
L=N 

NL\=L*LA 

LL\=NIA-IA 

L IS THE ROW INDEX OF THE ELIMINATION 

IF ( L-3) 360,40,40 

LL\=LIA-LA 

L1=L-1 

L2=L1-1 

SEARCH FOR THE PIVOTAL ELEMENT IN THE LTH ROW 
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0585 



ISUB-LIA+L 

0586 



IPIV-ISUB-IA 

0587 



PIV«ABS(A(IPIV)) 

0583 



IF(L-3) 90,90,50 

0589 


50 

M=IPIV-LA 

0590 



DO 80 I»L,M, IA 

0591 



T=ABS(A(I)) 

0592 



IF(T-PIV) 80,80,60 

0593 


60 

IPIV-I 

0594 



PIV-T 

0595 


80 

CONTINUE 

0596 


90 

IF(PIV) 100,320,i00 

0597 


100 

IF( PIV-ABS(A(ISUB) ) ) 180,180,120 

0593 

C 



0599 

C 


INTERCHANGE THE COLUMNS 

0600 

C 



0601 


120 

M=IPIV-L 

0602 



DO 140 1=1, L 

0603 



J=M+I 

0604 



T=A(J) 

0605 



K=LL\+I 

0606 



A(J)=A(K) 

0607 


140 

A(K)=T 

0608 

C 



0609 

c 


INTERCHANGE THE ROWS 

0610 

c 



0611 



M=L2-M/L\ 

0612 



DO 160 I=L1 ,NIA , IA 

0613 



T-A(I) 

0614 



J = I -M 

0615 



A(I)=A(J) 

0616 


160 

A( J)=T 

0617 

c 



0618 

c 


TERTIS OF THE ELEMENTARY TRANSFORMATION 

0619 

c 



0620 


130 

DO 200 I=L,LIA,IA 

0621 


200 

A(I)=A(I)/A(ISUB) 

0622 

c 



0623 

c 


RIGHT TRANSFORATION 

0624 

c 



0625 



J=-IA 

0626 



DO 240 1=1, L2 

0627 



J=J+IA 

0623 



LJ=L+J 

0629 



DO 220 K=1 ,L1 

0630 



KJ=K+J 

0631 



KL=K+LIA 

0632 


220 

A ( K J ) =A ( K J ) -A ( L J ) *A ( KL ) 

0633 


240 

CONTINUE 

0634 

c 



0635 

c 


LEFT TRANSFORRATION 

0636 

c 
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0637 

0638 

0639 

0640 

0641 

0642 

0643 

0644 

0645 

0646 

0647 

0648 

0649 

0650 

0651 

0652 

0653 

0654 

0655 

0656 

0657 
0653 

0659 

0660 
0661 
0662 

0663 

0664 

0665 

0666 

0667 

0668 

0669 

0670 

0671 

0672 

0673 

0674 

0675 

0676 

0677 
0673 


K=-IA 

DO 300 I-l,H 
K=K+IA 
LK-K+Li 
S-A(LK) 

LJ-L-IA 
DO 280 J=1 ,L2 
JK-K+J 
LJ-LJ+IA 

280 S=S4A(LJ)*A( JK)*1 . ODO 
300 A(LK)=S 
C 

C SET THE LOWER PART OF THE MATRIX TO ZERO 

C 

HO 310 I=L,LIA,IA 
310 A ( I ) =0 . 0 
320 L=L1 

GO TO 20 
360 RETURN 
END 

SUBROUTINE MLTMX(A, S,M,MDIM) 

C 

C SUBROUTINE OBTAINS THE MATRIX MULTIPLICATION OF A AND S AND 
C THE RESULTS IN S. 

C 

D IMENS ION S ( MD IM , MD IM ) , A ( MD IM , MD IM ) 

COMMON/WO RK/T ( 25,25) 

DO 10 1=1, M 
DO 10 J = 1 , M 
C=0.0 

DO 20 K=1,M 
20 C=C+A( I , K) ,V S(K, J) 

10 T( I , J )=C 
DO 50 1=1, M 
DO 50 J=1,M 
50 S( I , J )=T(I , J) 

RETURN 
END 

BLOCK DATA WORK 
COMMON /WORK/ WO (6 25) 

END 


&FXLTR T-00004 IS ON CR00022 USING 00004 BLKS R-0022 


0001 

0002 

0003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 
0011 
0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 
0021 
0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

0030 

0031 

0032 

0033 

0034 


FTN4.L 

PROGRAM FILTR 
C WRITTEN BY E. E. SHERROD 
C 

C THIS PROGRAM SELECTS THE FILTERING TYPE 
C 

DIMENSION ILU(5) ,NAME1(3) ,NAME2( 3) , IRTN(5) ,NAME3( 3) 
EQUIVALENCE (IRTN( 2) ,RMAX) , (IRTN(4) ,RMIN) 

DATA NAME 1 / 2HLF , 2HLT , 2HR / 

DATA NAME2/2HHF, 2HLT, 2HR / 

DATA NAME3/2HSH, 2HOW , 2H / 

C 

C GET LU 
C 

CALL RMPAR(ILU) 

I PI XL -0 
JPIXL -511 
LU-ILU(l) 

WRITE(LU.IO) 

10 FORMAT(" SELECT FILTERING TYPE "/" 1. LINEAR 2. HOMOMORP 
READ(LU,*) IFTTR 

IF ( IFITR .EQ. 1) CALL EXEC( 23 , NAME 1 ,LU,IPIXL, JPIXL, 0,0) 

CALL RMPAR(IRTN) 

IF ( IFITR .EQ. 1) GO TO 3 ) 

IF ( IFITR .EQ. 2) CALL EXEC(23,NAME2,LU,IPIXL, JPIXL, 0,0) 

CALL RMPAR(IRTN) 

30 WRITE(LU, 40) RMAX.RMIN 

40 FORMATC MAX PIXEL - " ,F12 . 2 , 10X, " MIN PIXEL - *‘,1FI2.2) 
IX-RMAX-RMIN +0.5 
WRITE(LU, 50) IX 

50 FORMAT( " NUMBER OF GRAY LEVELS - " ,15) 

IF ( IFITR .EQ. 2)CALL EXEC(23,NAME3,LU, 0,511 ,0,0) 

STOP 

END 
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JLMOISE T-00004 IS ON CR00022 USING 00010 BLKS R-0097 


0001 

FTN4.1 

L 

0002 


PROGRAM NOISE 

0003 

C 


0004 


DIMENSION RDATA(512),GNOISE(512),LU(5),IU(5),IBUF(40) 

0005 

C 


0006 


INTEGER READL 

0007 


EQUIVALENCE ( RDATA , LU( 2 ) ) , (LU( 2 ) , ILINE ) , (LU( 3 ) , IPIXL) , 

0008 


l (RDATA(2),RMAX),(RDATA(3),RMIN) 

0009 


DATA RDATA/512*0.0/ 

00L0 

C 


0011 

C GET 

INPUT PARAMETERS 

0012 

C 


0013 


CALL RMPAR(LU) 

0014 

C 


0015 

C SCHEDULE BUILD WORK FILE PROGRAM 

0016 


CALL EXEC(23,6HBLDWF ,IU) 

0017 

C 


0013 

C READ WORK FILE HEADER 

0019 

C 


0020 


IERR - REA0L(-1 ,0,511, RDATA) 

0021 


IF (IERR .LT. 0) GO TO 999 

0022 


NLINE-ILINE 

0023 


NPIXL=IPIXL 

0024 


PMAX*RMAX 

0025 


PMIN-RMIN 

0026 

C 


0027 

C GET 

NOISE IFFO 

0028 


WRITE(LU, 13) 

0029 

13 

FORMAT (" ENTER NOISE MEAN VALUE ") 

0030 


READ(LU, *) AM 

0031 


WRITE(LU, 14) 

0032 

14 

FORMAT( ” ENTER STANRARD DEVIATION VALUE ”) 

0033 


READ(LU,*) S 

0034 


IF(S .LE. 0) GO TO 1000 

0035 

C 


0036 


DO 100 I«0,NLINE-1 

0037 


IF (READL(I,0,NPIXL-1 , RDATA) .LT. 0) CO TO 999 

0038 

c 


0039 

C GET 

NOISE 

0040 

C 


0041 


DO 101 JA-0,51 

0042 


CALL EXEC(l,8,IBUF,40) 

0043 


JJ=10*JA 

0044 


CALL CODE (80) 

0045 


READ( IBUF.12) (GNOISE(K+JJ) ,K*1 , 10 ) 

0046 

12 

FORMAT( 10F8. 5) 

0047 

101 

CONTINUE 


0048 

C 


0049 


DO 90 J «*l,NPIXL 

0050 


RDATA(J)‘ RDATA(J) -KJNOISE( J)*S4AM 

0051 

600 

FORMAT ( F20.3) 

0052 

90 

CONTINUE 

0053 

C 


0054 

C WRITE SIGNAL + NOISE TO WORK FILE 

0055 

C 


0056 


IF(RITEL(I,0,NPIXL-1,RDATA) -LT. 0) GO TO 999 

0057 


IF (MOD(I, 64) .EQ. 0) WRITE(LU,4) 

0058 

4 

FORMAT (“ **** ADDING NOISE ****") 

0059 

100 

CONTINUE 

0060 

C 


0061 

1000 

CALL CLSWF(NLINE , NPIXL , PMAX , PMIN ) 

0062 


CALL CLOSE(IDCBl) 

0063 


CALL EXEC(6) 

0064 

999 

WRITE (LU, 2) IERR 

0065 

2 

FORMAT( "FILE ERROR", 17) 

0066 


END 

0067 

$ 
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Stability Analysis of Two-Dimensional 
Digital Recursive Filters 

WINSER E. ALEXANDER, member, ieee. and STEVEN A. PRUESS 
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I. Introduction 

two-dimensional digital recursive filter can be char- 
acterized by the bivariate difference equation 

g(m,/i)- 2 2 a JK f(m-J,n-K) 

J - o A-0 

“ 2 2 */*«("»-•'>'»-*) (0 
y-o a-o 
/+*> o 
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where the coefficients a JK and b JK arc constants [I] and 
some of these constants may be zero. In general, this form 
does not require that the corresponding numerator and 
denominator polynomials for the two-dimensional Z 
transform of the transfer function both be of degree L. 
Zeros may be added to form the structure as given in (1). 
There are two major problems to consider in the design of 
recursive filters for two-dimensional signal processing: 
synthesis and stability. The synthesis problem consists of 
determining the filter coefficients so that the required 
frequency response is realized. If the resulting filter is to 
be useful, it must be bounded-input-bounded-output 
(BIBO) stable. In this paper the stability problem is con- 
sidered and a new approach to stability analysis for the 
two-dimensional digital recursive filter is presented. 

For the one-dimensional case, there are essentially two 
methods of determining necessary and sufficient condi- 
tions for stability of digital filters: examining regions o 
analyticity for the characteristic polynomial and by direct 
evaluation of the characteristics of the impulse response 
[2]-(4]. In particular, if the system corresponding to the 
digital filter is represented by a state-space equation, then 
one can determine stability from the coefficient matrices 
in the state-space equation [4]. For the two-dimensional 
case, generalizations of the first method involves examin- 
ing regions of analyticity for bivariate polynomials [5]. 
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Thii paper attempts to generalize the second method for 
die two-dimensional case, i.e., to establish stability by 
computing the spectral radii of coefficient matrices with 
real coefficients. The spectral radius of a matrix is the 
magnitude of the largest magnitude eigenvalue of that 
matrix. 




0 

0 

0 

0 


II. Pseudo-State-Space Representation 

A pseudo-state-space representation of (I) is used in the 
development of the stability analysis theorems in this 
paper. This representation is very similar to a state-space 
representation of the two-dimensional digital recursive 
filter as defined by Fomasini and Marchesini (6). The two 
can be made to be equivalent by letting one of the 
coefficient matrices in the Fomasini and Marchesini 
model be the null matrix. The pseudo-state-space repre- 
sentation of the two-dimensional recursive filter is given 
by 

G m,* m B\ G m,n-l + BlG m _ Kn + A F m , 

g(m,n)-DG m . 

G mn is a column vector such that its elements are the 
outputs, g(m-J,n~K) where 0 <J<L and 0<K<L. 
Note that G m „ contains all of the outputs that are repre- 
sented in (1) including g(m,n). Similarly, /■_ _ is a column 
vector such that its elements are the inputs, /(m- J,n- K) 
where 0<J<L and 0<K<L. _ _ _ 

We can then define matrices B,, B 2 , and /4J7] such that 
(1) and (2) are equivalent. The matrices B,, B v and A are 
all of order (La- l) 2 by (La- l) 2 . The vector D is a row 
vector with La- 1 elements. 

The ordering of the outputs in G m „ and of the inputs in 
F m n is not unique. However, the ordering does affect the 
relative position of the elements of the corresfonding 
coefficient matrices. Also note that G m _ , „ and G mn _ , 
have elements in common. Where this occurs, the corre- 
sponding elements of B, and B 2 can be divided such that 
the magnitude of each is no larger than that of the 
corresponding b JK or one as appropriate. It is convenient 
to consistently divide equally and choose a particular 
ordering scheme for G m „. 

Example 

Consider the two-dimensional digital recursive filter 
with bivariate difference equation given by 

g(m,n)-a 00 f(m,n)Aa lo f(m-l,n)Aa ol f(m,n I) 

Aa i{ f(m-\,n-l)-b io g(m-l,n) 

-^iff(»»,rt-l)-B„g(»i-l,fi-l). (3) 

For this example, with G m „ and F m „ given in transpose 
form, we have 

[*('".'») g(m-ln) g(m,n— 1) g(m - l,n - l)] r 

(4) 

F mn - [/(">.«) A m ~ !>*) f(m- l,n— 1)] T 

(5) 



B,- 


- b 0l 

0 

I 

0 



0 

0 

\_ 

2 


0 0 

0 0 
0 0 

0 0 


A - 


«oo 

0 

0 

0 


«io 

0 

0 

0 


«oi 

0 

0 

0 


«ll 

0 

0 

0 


III. Stability Analysis 


( 6 ) 


(7) 


The stability analysis herein will be confined to the 
linear shift invariant (LSI) two-dimensional discrete sys- 
tem. Such a system is BIBO stable if and only if the 
discrete impulse response of the system, h(m,n ), is ab- 
solutely summauie, i.e., 2JS, )l „ ( J*( w * fl )K 00 (I). 

Let us define the particular vector H JK as that input 
vector which represents a single unit sample at the (J, K) 
position of the two-dimensional data array with all other 
inputs samples zero. Let us further define the initial condi- 
tion vectors, G / _, K and Gj K . as null vectors. Then for 
m ■ J and n — K, (2) reduces to 


g j,k~ ■d Hj.k 

h(J,K)- DG j k . (8) 

Define the term C(B{,B 2 ) as the^sum of ail product 
terms involving all permutations of B, as a factor J times 
and B 2 as a factor K times. It is helpful to note that if B ( 
and Bj commute, then 

C( B', B?) - ( J + * ) B J X B* ■(/ + *)! B j'BfyU ! K !). 

In gener\l, the matrices do not jxjmmute^ Tlicrefore, we 
give as an example / ‘^ 2 + B X B 2 B X + B 2 Bf. 

Lemma 1 

The contribution to the output vector, G m for a single 
input vector, which corresponds to a unit impulse at 
the (/, /^position where J <m and K<n % is given by 
G mt n m K for the LSI system repre- 

sented by (2). 

The proof of Lemma 1 is given in the Appendix. 
Lemma 1 provides a convenient means of finding the 
output of the two-dimensional digital recursive filter for 
all values of m and n when the filter is excited by a single 
input at any point in the array. Since the filter is linear 
and shift invariant, we can use the principle of superposi- 
tion to find the output for any particular sequence of 
inputs. Thus the unit impulse response of the filter is given 
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I) 


by 

G mm -c(Br,B;)AH o.o (9) 

h(m.n)-DG mn -DC(Br.B;)AH 0 0 . ( 10 ) 

Lemma 2 

Given the discrete LSI system represented by (2) for 
which the corresponding transfer function has mutually 
prime numerator and denominator polynomials. If the 
contribution to the output vector G mn by a bounded 
sequence of input vectors F J K where 0<J <m and 0<K 
<n can be expressed by G mn « Q m AF JK or ( 7 m „ - 
Q"AFj K , then the system is unstable if p(Q), the spectral 
radius of Q, is greater than one. The proof of Lemma 2 is 
given in the Appendix. 

Theorem / 

The discrete LSI system represented by (2) is stable if 
and only if for at least one matrix norm 

s- i 2 noc(«r ^)^"o.oii<« od 

m«0 n — 0 

Theorem 1 follows directly from (10) and the require- 
ment that the discrete impulse response be absolutely 
simmable. Since h(nun) is a scalar, its matrix norm is 
equivalent to its absolute value and the proof of Theorem 
1 is obvious. 

Theorem 2 

The discrete LSI system represented by (2) and for 
which the numerator and denominator polynomials of the 
corresponding transfer function are mutually prime is 
unstably if any one of the spectral radii p(Z?,), p(B 2 ), or 
p(B x + B 2 ) greater than or equal to one. The proof of 
Theorem 2 is given in the Appendix. 

In the practical application of two-dimensional_digital 
recursive filters, any filter with p(B ,), p(B 2 ), or f>(B , + B 2 ) 
equal to one can be considered to be unstable and should 
be avoided [8]. Goodman (5] has shown by clever exam- 
ples that two-dimensional filters with nonessential singu- 
larities of the second kind on the uni^ bidisc may be 
stable. Such a filter may have p(Z?,), p(B 2 ), or p(B { + B?) 
equal to one. However, roundoff errors and coefficient 
truncation would prevent satisfactory performance by 
such a filter for most applications. 

IV. Conclusions 

In this paper, a new approach to stability analysis of 
two-dimensional digital recursive filters has been pre- 
sented. Theorems have been presented which can be used 
in the practical application of this approach. The authors 
feel that it is important to note that no known unstable 
filter has been found in this research effort which did not 
have either p(fl 2 )* or P(#i + * 2 ) greater than or 

equal to one. One is lead to conjecture that for a large 
class of filters, any filter in the class is stable if the subject 
spectral radii are all less than one. However, the proof of 
this is not trivial. 


Several other theorems relating to sufficient conditions 
for stability have been found (7). However, it has been 
shown that these constraints are too restrictive for general 
use. That is, useful stable filters can be found which do 
not satisfy the corresponding sufficient conditions for 
stability. 

Computer algorithms are readily available to find the 
spectral radius of a matrix with leal coefficients. Thu* 
Theorem 2 presents a convenient and easily implemented 
technique to assess the stability of two-dimensional digital 
recursive filters. 

Appendix 

In this Appendix, the proofs for Lemmas 1 and 2 and 
Theorem 2 are given. When a specific norm is not given, 
any convenient norm is appropriate. 

A I. Proof of Lemma 1 

We proceed with a proof by induction. If we use (2) and 
(8) to obtain <7 y +, and (/,+,*+, for input 

vector Hj K *nd if all initial condition vectors are null 
vectors, we obtain 

“ B X G JA “ &\A Hj.x 

i,x> 1 * xjc -{B x B 2 +B 2 B x )A H j k 

(Al) 

If we use Lemma I, we obtain 

i,at ■" C{B\> B 2 )a H jk « B X A H jk 
Gj.k* . “ C(B?> Bj)AH JK - B 2 AH JK 

Gj + i,#>i — Hj B 2 B,)a Hj k 

(A2) 

Thus for any arbitrary m and n such that m >J and n >K, 
we can use (2) to write 

G m + in * B x G mn + B 2 G m + ! ,. (A3) 

li en using (9) to find expressions for G mn and (7 m + , 
we have 

G m ^. n ^[B l c(Br J Jr K ) 

+ b 2 c(b?- j +\b;~ k -')]ah jk . ( a 4 > 

Consider the term, C(B X ,B 2 ). All of the products in the 
term either^have B x as the first factor or B 2 as the first 
factor. If B { is the first factor, we must postmultiply by 
the sum of all possible products such that the power of B x 
is decreased by one. If B 2 occurs as the first factor, we 
must post-multiply by the sum all possible products such 
that the power of B 2 is decreased by one. We conclude 
that 

c(§i, B*) - B x c( Bi - \ B 2 ) + B 2 C(b' , B«-') ( A5) 
for all J and K , such that both J and K are greater than or 
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equal to one. It follows directly that 

G m ^C(Sr x -\Br K )AH JK . (A6) 
Similarly from (2) we can write 

Gm.114.1"* B 2 G m „. (A7) 

Using (9) to find expressions for <7 m _ ( and G m „, we 
have 

+ B 1 C(B?- J ,Br*)]AH J ' K . (A8) 

It fellows that 

<V»+ , - C(Br J . Mr*- (A9) 

Finally, from (2> we obtain 

G m+ l,«+ I " *1 Cm./.* I + Ml G m* t.n- ( A1 °) 

Using Lemma t to express G mn+ , and G„, + we obtain 

G m ^ l -[B l c(Br J ,Mr l - K ) 

+ B 2 C(Br'-'.Sr*)]AH JJC . (All) 
It follows from (A5) and (All) that 

G m ^ x -C{Br [ - J ,Br'- K )AHj_ K (A 12) 

and Lemma I holds. 

A 2. Proof of Lemma 2 

In the proof of Lemma 2, we shall show that if the 
response to a particular sequence of input vectors can be 
represented as_ given in Lemma 2, then the system is 
unstable if p(Q)> 1 (9). 

Define the eigenvalue corresponding to the spectral 
radius of Q as Xq and the corresponding eigenvector as 
Pq. Then if the system transfer function has mutually 
prime numerator and denominator polynomials we can 
select a sequence of input vectors such that 


From Lemma I the output from a single arbitrary 
bounded input at the (J.K) position can be given by 

G MN m f(J,K)C{B^ J ,8 2 K )AH JK 

g(M,N)-DG UN (A16) 

where /(/, Af) is the scalar input at the (J,K) position. If 
we let Af- N and ./• 0 in (A16), we have 


G m , n -A*.N)C{B“,B°)A H« n -A0,N)B“A h % m . 

(A17) 

If we apply Lemma 2, we see that the system is unstable if 
p(fl,)> 1. If we let J ■» M and Af-0 in (A16), we have 

n -AM,0)C( fl,°, b 2 )a M, 0)B?A H„ 0 . 

(A18) 

If we apply Lemma 2, we see that the system is unstable if 

P(B j)>\. 

If we use a particular sequence of inputs for 

0<J<M where all are bounded and equal. 

Using the principle of superposition and (A16) we have 

G„.„- 2 f{J,M-J)C{B?- J ,Bi)AH JM „j. 
y-o 


Since all inputs are equal, we can write 


(AI9) 




“/(o 9 M)\ 


M 


2 c{b?- j :b() 


j - o 


AH, 


O.M 


(A20) 


C«.M-/(0,A/)(B, + fl 2 ) M >l// o .„ (A21) 

since 

2 C(«r'i57) (A22) 

j ■ o 

whether or not 2?, and B 2 commute. If we apply_Lero-na 2, 
we see that the system is unstable if p(Z), + fl 2 )> 1 and 
Theorem 2 holds. 


A Fj „ ■» (.Pq + Rj ., for all J and n. (A13) 

where c is an arbitrary nonzero finite constant and R Jn is 
not in the direction of Pq. We then have 

G m ,„ - Q m A F J n - c Q”P q + Q m R J n . (A14) 

Then since is the eigenvalue corresponding to the 
spectral radius, the norm of G m n is dominated by the term 
tQ m pQ in the limit as m approaches infinity. Thus 

lim ||G || - Urn \\(Q m P Q \\ = jim ||*^P e ||. 

(A15) 

Note that S is infinite if \q is greater than one and 
J,emma 2 holds. 

A3. Proof of Theorem 2 

For this proof, we show that we can find a particular 
sequence of inputs that give unbounded output if any one 
of the spectral radii specified in Theorem 2 is greater than 
one. 
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The Matrix Recursive Form 


ABSTRACT 

This paper presents a new procedure for 
stability analysis of two dimensional recursive 
digital filters. A matrix recursive e nation 
which is similar to the state space representa- 
tion of the one dimensional digital recursive 
filter to formulated. This matrix recursive 
equation is used to assess stability of the two 
dimensional digital recursive filter in terms of 
the spectral radii of the coefficient matrices. 

Examples of the use of this technique co 
assess stability of two dimensional digital 
recursive filters are given. It is demonstrat- 
ed that this technique reduces the stability 
analysis problem to examining the spectral radii 
of matrices with constant coefficients. 


INTRODUCTION 

A causal two dimensional digital recursive 
filter may be represented by the bivariate 
difference equation 


£ a f(m-J,n-K 


J-0 K-0 


i t 

>0 K-0 
J+K>0 


b JK g(®-Jtn-K) 


where some of the coefficients a and b may be 
zero. Such a filter u^es feedback of past output 
values to calculate the current output. There- 
fore, it may be bounded input-bounded output (BIBO) 
unstable. That Is, the output may net be bound- 
ed for a given bounded input. This paper con- 
siders this stability problem and present a simple 
technique to assess stability of two dimensional 
recursive digital filters. 


The bivariat 
by (1) can be desc 
equation 

C • B.G . 
ci , n m-I 

where C i a co 

m *n 

in (1), F is a 
inputs in (I) and 
appropriate metric* 
The matrices B 

by (L+i) 2 . The cu 

g(m t n) « DO whe 
i . m , n 

elements . 


e difference equation represented 
ribed by the matrix recursive 


+ B ,G . + AF (2) 

,n -2 m,n-l - m,n 

lumn vector made up of all outputs 

column vector made up of all 
the matrices B^, and A are 
es to make (lj and i2) equivalent. 
2 and A are all of order (L+l) 

rrentfputpuj then given by 
re D is a row vector with (L+l) 


The ordering of the outputs in G and of the 
inputs in F is aoL unique. HoweverI n the order- 
ing does af?£ct the relative position of the 
elements of the corresponding B. and matrices. 
Also note that there are identical elements in 
and B^. Where this occurs, the corresponding 
elements of B. and can be divided such that the 
magnitude of each is no longer than that of the 
corresponding b ^ or one as appropriate, It is 
convenient to consistently divide ea ly and 


choose a particular ordering scheme. 


Example 1 

Constdei the recursive digital filter with 
bivariate difference equation given by 

g(m,n) - f(m,n) - b 1Q g(ni-l,n) - b 01 g(m,n-l) 

- b 11 8(m-l,n-l) (3) 

Tor this example, we have 

g(m,n) f(m,n) 

c g(m-l ,n) f (m-1 ,n) 

ffifn " g(ra,n-I) * • f(m,n-l) 

g(m-l,n-X) f (m-l,n-X) 
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and 


-10 

0 

4b n 

0* 


» 

c r 
o 

-4b u 

0 

0* 

1 

0 

0 

0 


0 

0 

0 

0 

0 

0 

0 

0 

‘ B -2 - 

1 

0 

0 

0 

B 0 

0 

4 

0 a 


0 

H 

0 

0^ 


(5) 


( 6 ) 


Stability Analysis 

For the one dimensional case, there are 
essentially two metnods of determining necessary 
and sufficient conditions for stability; examin- 
ing regions of analyticity for the characteristic 
polynomial and by direct evaluation of the charac- 
teristics of the impulse response [l,2,3]. In 
particular, if the filter is represented as a 
state space equation, then one can determine sta- 
bility from the coefficient matrices in the state 
space equation £)]. The usual approach for sta- 
bility analysis of two dimensional digital recur- 
sive filters involves examining regions of analy- 
ticity for bivariate polynomials [4] which is com- 
putational feasible onlv for very simple filters. 
This paper represents an attempt to generalize 
the second method for the two dimensional case, 
i.e. to establish stability by computing the spec- 
tral radii of coefficient matrices with real 
coefficients. 

The following theorems relating to stability 
analysis of two dimensional digital recursive 
filters have been developed £5]. Space will not 
allow proof of the theorems in this paper. The 
reader is referred to reference [5] for further 
details. 


Theorem 3 

There Is a particular permutation 
matrix S [5] such that if p(§j)« 

pfBj + B 2 ) are all less than one, then the LSI 
digital recursive filter is stable if both p(BjS) 
and p(&2 S ) are c ^ an one-half. 

Conjecture 

If the coefficients of (1) are symmetric such 
that for all J and K, th*,n the LSI recur- 

sive digital filter described by (2) and for which 
the numerator and denominator polynomials of the 
corresponding transfer function are mutually prime 
is stable If and only if p(Ej), p(§ 2 ). and 2^ 

are all less than one. 

Example 2 

From Theorem 1, we obtain the results that the 
filter represented by (3) is unstable if b m | >. 1 » 

ho| il. °r if ' ^ 

ffiax ^|~ (b 10+ b 01 

E xample 3 

Consider the example (also used by Shanks [6j) 
where the bivariate difference equation is given by 

g(m,n) « f(m,n) + 0.95 g(m-i,n) + 0.95 g(m,n-l) 

-0.5 g(m-l ,n-l) (8) 

If we apply Theorem 1, we obtain P^) ■ 0.95, 
p(B^) - 0.95 and p(B x + B 2 ) - 1.584, Thus it 
follows that this filter is unstable. 

E xample 4 

Consider the example used by Read and Treitel 
[7] with bivariate difference equation given by 


>* i^ b 10^ b 01 )2 " 4b li|]- - 


(7) 


Theorem 1 

The linear space invariant (LSI) two dimen- 
sional digital recursive filter represented by (2) 
and for which the numerator and denominator poly- 
nomials of the corresponsing transfer function are 
mutually prime is unstable if any one of the spec- 
tral radii p(B. ) , p(§ 2 ), p(B + Bj is greater 
than or equal to one. The spectral ratius of a 
given matrix is the magnitude of the largest magni- 
tude eigenvalue of that matrix). 

Theroem 2 

The LSI two dimensional digital recursive 
filter represented by (2) is stable if the spectral 
radius of the matrix made up of the sum of the 
magnitude of the coefficients of and is less 
than one (p [abs (B^) + abs (B 2 )]<1). 


g(m,n) - f(m,n) + 0.75 g(m-l,n) -1.5 g(m,n-l) 

J 0.9 g(m-2,n) - 1.2 g(m,n-2) - 1.3 g(m-2,n-l) 

-0.9 g(m-l,n-2)- 0.5 g(m-?,n-2) (9) 

If we apply Theroem l, we obtain p(B^) * 1.095, 
p(B 2 ) - 0.949 and pU^+j^) * 1.284. We conclude as 

did Read and Treitel that this filter is unstable. 

Example 5 

Consider the example by Huang [8] with differ- 
ence equation given by 

g(m,n) ■ f(m,n) - 0.5 g(m-l,n) -0.5 g(m,n-l) 

-0.25 g(o-l,n-l - 0.25 g(m-2 # n) -0.25 g(m,n-l) (10) 
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f* 


If we apply Theorem J # we obtain p(B^) ■ 0.5, 

p(B,) - 0.5, p(B x + B 2 ) - 0.866; PiJ^S) - pfl^S)- 

0.35355. Therefore, we conclude that thla filter 
is stable. This filter was verified to be stable 
by Marla and Fahmy [8]. 


Example 6 


Consider the example used by Huang [8] with 
difference citation given by 


g(ra,n) - f (ra, n) - b l0 g(m-l ,n)-b 0 jg(m,n-l) (11) 


If we apply Theorem 2, it is Interesting to note 
that we get the same sufficient condition for 
stability as obtained by Huang: 



In consider tr 3 more complex example;., it is 
convenient to present the coefficients bj ^ in 
matrix form. Let the matrix V be made up of the 
elements V JK for row J and column K where 

V JK * kj i For example, the V matrix corre- 

sponding to example (1) is given by 


V 



(13) 


Note that £ is of order (L+l) by (L+l) . 


Examo le 7 


Consider the example used by Read and Treitel 


where 

V is given 1 

by 





r 







1.0 

1.5 

-1.9 

-0.8 

1.1 



1.4 

2.1 

-2.6 

-1.1 

1.5 


V - 

-1.8 

-2.4 

3.3 

1.3 

-1.6 

(14) 


-0.7 

-0.9 

1.1 

0.5 

-0.8 



-0.9 

1.3 

-1.6 

-0.6 

1.0. 


For thix example, 

P(B X ) - 

2.169; 

p<V 

- 2.104 


and piB^ + B^) » 2.599. Thus Read andTreitel's 
conclusion that this filter is unstable is verified. 


CONCLUSION 

A new procedure for assessing stabilfty of 
two dimensional recursive digital filters has been 
presented. The formulation of the and B- 
matrices is very siinpLe and straight forward and 
the matrices are sparse (mostly zeros). Computer 
algorithms are readily available to obtain the 
spectral radius of a matrix with real coefficients. 
Thus stability analysis is greatly simplified with 
respect to methods which have previously been 
presented . 

It is also important to note that in this 
research effort all known unstable filters have 
been detected as being unstable when Theorem 1 was 
applied. We surmise that for a very large class 
of filters, any filter within the class not detect- 


ed as being unstable after applying Theorem 1 Is 
stable. Research continues to prove or disprove 
this conjecture. 
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Abstract 

This paper presents a design technique for 
designing approximately circularly symmetric 
lowpass, hlghpasa, bandpass, high frequency boost 
and low frequency boost digital filters for 
subjective image processing applications* An 
approach Is used which parallels the use of the 
Butterworth, Chebychev or other type of polynomial 
approximations to obtain one dimensional lowpass 
digital recursive filters. The other filter designs 
are then derived from the lowpass filter design. 
The designed filters are very close to being 
circularly symmetric for e wide range of critical 
frequencies. In the design procedure, the squared 
magnitude characteristic of the desired circularly 
symmetric filter is chosen in the Laplace Transform 
domain. The bilinear transformation is then used to 
map the squared magnitude characteristic Into the 
two dimensional ZW-Transform domain* A pseudo-state 
space representation for the corresponding two 
dimensional ZW-Transform is obtained. The 
eigenvalues with magnitudes less than one are then 
used as roots of a denominator polynomial with 
distinct roots to form the ZW-Transform of the 
stable two dimensional digital filter. 


1*0 INTRODUCTION 

There are basically two types of image 
processing: subjective Image processing and image 
correction. Subjective image processing involves 
the modification of an Image in some way to improve 
the ability of the observer to obtain information or 
to Improve the appearance of the image. Image 
correction involves the removal of noise or other 
errors in the image caused by the system producing 
the image. This paper primarily addresses the 
design of digital filters for use in subjective 
Image processing. 

The user Interested in subjective Image 
processing typically desires a variety of filters 
that can be applied based upon experience or a 
preliminary evaluation of the subject image. He 
then wants to observe the results of this filtering 
operation and make adjustments In the filter 
parameters before filtering again* Therefore, a 
computationally efficient algorithm is desirable and 
fast turn around is vital* 

The two dimensional recursive digital filter Is 
a good choice to meet these requirements ( 1 ] • The 
size of the image Is not constrained to powers of 
integers and the number of computations per pixel 
does not Increase as the size of the image Is 
increased. In addition, the Image is processed by 
row which is the normal mode for storage of imaged 
on tape or disk. 

The common techniques of edge enhancement, 
contrast enhancement, dynamic range compression, 
etc. may be accomplished with recursive digital 
filters. These applications Involve lowpass, 


hlghpass, bandpass, high boost and low boost digital 
filters. This paper presents a design technique 
which can be used to design approximately circularly 
symmetric recursive digital filters* 


2*0 MATHEMATICAL THEORY 

The theoretical basis for the two dimensional 
ZW-Transform [2] involves the theory for sample data 
systems* Given discrete samples of a two 
dimensional function, f(x,y) with sampling 
increments X and Y respectively, the ZW-Transform 
for the function is defined by 

CD <X) 

F(z ,w) * ^ ^j^f(mX,nY)z °w n (2*1) 

m»-a> n--flD 

If the function is an image, then (2*1) reduces to 
the case where m and n have no negative values and 
the range o c m and n is finite. We further restrict 
the problem to the case where X and Y are constants. 
Then, if we use the notation f(ra,n) to represent 
f(mX,nY), we have 

M N 

F(z,w) - ^jjT f ( ra,n)z D w n (2.2) 

m-0 n“0 

as the ZW-Transform for the image function, f(ra,n), 
which has (M + i) columns and (N + I) rows. 

Consider the case where we have an Input Image 
with samples f(m,n) and we wish to filter this Image 
to obtain an output image with corresponding 
samples, g(m,n)* The samples of the impulse 
response of the desired filter are given by h(m,n). 
The range of m and n for the output Is the same as 
for the input. Thus, the ZW-Transform of g(m,n) is 
given by 

M N 

C(z,w) - 22 g(m,n)z m v n (2.3) 

m*0 n*0 

If we restrict the Impulse response such that m and 
n cannot be negative (a causal system), we can vrlte 
the ZW-Transfcrm for the Impulse response as 

ot oo 

H(z,w) - 22 h(m,n)z “w n (2. A) 

m»0 n"Q 


In general, the ZW-Transform for the Impulse 
response is an infinite series. In order to 
Implement the spatial domain filter, we must find a 
closed form expression for H(z,w) such tnat 
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H( z,w) - 


L L 

2 2 

J-0 k-0 

L L 

2 2 b( - 1 * k) *’' 8w ’ n 
j-0 k-0 


(2.5) 


The convolution property of the ZW-Tranaform gives 
the relationship resulting from the convolution of 
t(ra,n) and h(a,n) which is the filtering process 

C(z,v) - rf(z,w)F(z,w) (2.6) 


The two dimensional stability problem Is very 
complicated If the polynomial In the denominator Is 
not factorable Into distinct roots { A J • Efforts by 
other researchers have been directed toward 
examining regions of roots for two variable 
polynomials* An alternate method of assessing 
stability for one dimensional digital recursive 
filters Is to make a state space representation of 
the filter [5J* Then the filter Is stable if the 
eigenvalues of the state transition matrix all have 
magnitudes less than one* Previous research has 
been directed toward developing the two dimensional 
equivalent of this procedure [6,7 J. A pseudo-state 
variable representation Is chosen because of 
difficulties In finding a true state space 
representation (6). This difficulty is caused by 
the bivariance of the transfer function and by Its 
causality* The resulting matrix equation has two 
pseudo-state transition matrices* 


If ve use the closed form of H(z,w) and restrict 
b(0,0) to be equal to one and write the resulting 
equation for a single output value g(m,n), we obtain 
the difference equation 


g(m,n) - 


If L is relatively small (in practice, L is usually 
less than 10 for recursive digital filters), 
equation (2.7) represents a very efficient algorithm 
for filtering images. Equations (2.5) and (2.7) may 
also represent a nonrecursive filter if all b(j,k) 
except b(0,0) are equal to zero. 


L L 

21 a( j,k)f (m-J,n-k) 
j-0 k-0 

L L 

22 b( j*k)g(m- j ,n-k) (2.7) 

j-0 k«0 
* j+k>0 


Alexander [6] has shown that the recursive 
algorithm of (2.7) can be represented by the matrix 
recursive equation: 


G - SC . + CC , + AF m 

m,n m,n-l m-l,n m,n 


(3.1) 


that the elements of 
are the outputs g(m-j,n-k) In (2*7) where 0 < J 

that the 


Where G Is a vector such 
m,n 

C 

m,n 

< L and 0 < k < L. F is a vector such 
~ * m,n 

elements of F _ are the inputs f(m-j,n-k) In (2.7) 


m,n 


where 0 < j < L and 0 < k £ L. 1, C and 5 are 
appropriate coefficient matrices such that (2.7) and 
(3.1) are equivalent. 


If the filter Is unstable, then either 3, C or 
(I + C) has at 1 rt ast one eigenvalue with a magnitude 
greater than o. equal to one. Thus, stability 
analysis Involves setting up the matrices 5 and C 
and finding the spectral radius of each matrix 
individually and of their sum. 


4.0 SYNTHESIS 


3.0 STABILITY ANALYSIS 

Nonrecursive digital filters are inherently 
stable. Since there is no feedback of past output 
values, the Impulse response has finite duration. 
Each output value is a finite sum which is always 
bounded If the input is bounded. 

The stability problem for one dimensional 
digital recursive filters is straight forward. The 
roots of the denominator polynomial in the closed 
forn of the one dimensional Z-Transform for the 
filter impulse response function must have 
magnitudes less chan one. Stability analysis is 
therefore reduced to finding roots of nth degree 
polynomials with real, constant coefficients (3J. 
Stability analysis Is not straight forward for the 
two dimensional problem because a two variable 
polynomial is not generally factorable into distinct 
roots. When the polynomial in the denominator of 
the two dimensional Z-Transform of the impulse 
response Is factorable into distinct roots, the 
stability analysis procedure Is the same as for the 
one dimensional problem* 


Often it is possible to express a desired two 
dimensional recursive digital filter as the product 
or sum of two one dimensional digital filters. That 
Is, the ZW-Transform of the two dimensional filter 
may be expressed as the product 

H(z,w) - Hi (z)H2(w) (4.1) 
or as the sum 

H(z,w) - Hi (z) + H2(w) (4.2) 

In either case, the two dimensional synthesis 
problem Is reduced to the synthesis of two one 
dimensional filters [9,10]. However, It is not 
possible to design sum separable or product 
separable digital recursive filters for all 
applications. For theses applications where sum 
separable or product separable designs are not 
possible, the design of the required two dimensional 
digital recursive filter Is considerably more 
complicated. 

Many Imaging systems have a natural circular 
symmetry. In general, the optical transfer function 
(OTF) of a circularly symmetric Imaging system la 
circularly symmetric* Also, It Is usually desirable 
to perform Image processing where the processing is 
uniform with respect to direction. The natural 
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consequence Is that filters with circularly 
symmetric impulse response functions are generally 
very desirable for Image processing. A filter with 
a circuiarly symmetric impulse response is assured 
by restricting the Discrete Fourier Transfor (DFT) 
for the filter to be circuiarly symmetric 111 ). 

One popular method of designing digital 
recursive filters is to start with the Laplace 
Transform of the desired filtering function, make a 
suitable tranatorraat ion to the Z-Tranaform domain 
and thus obtain the cucffi:ients for the digital 
recursive filter. One such technique involves 
designing digital recursive filters from the squared 
magnitude characteristics of the desired filter 
which is really the squared magnitude of the Fourier 
Transform. This procedure is difficult to extend to 
two dimensions because of the difficulties 
encountered in factoring bivariate polynomials. 

To Illustrate this difficulty, consider the 
circularly symmetric Buttervorth low pass filter 
squared magnitude characteristic. 


However, the polynomial in the denominator of 
(4.6) is not factorable into distinct roots. 
Therefore, forming of the minimum phase version of 

H(*,w) is not straightforward and the design 

procedure is not successful. 

A minimum phase approximation to H(z,w) cun be 
obtained with the following procedure: 

1. Construct the coefficient matrices 5 and C of 
(3.0 which corresponds to (4.6). 

2. Calculate the eigenvalues of the matrix sum (U + 
C). They occur in reciprocal pairs. 

3. Fora the minimum phase approximation of the 

filter by using the smaller magnitude eigenvalue 
of each of the reciprocal pairs as a root of s 

and of w for the denominator polynomial and by 

using the minimum phase version ot the numerator 
polynomial. 

The resulting filter ZW-Transforro is given by 


H(r >b) 


i 

1 + (-l)"(r‘ + « 2 ) n /R 2n 


(4.J) 


H(z ,w) 


(l-t-p) 2 (z+l)(w+i> 
4 (z+pHv+p) 


(4.7; 


where r and a are the Laplace Transform variables 
for the \ and y direction respectively and R is the 
desired radial cutoff frequency. 

The bilinear transformation [9] can be used to 
obtain the corresponding recursive digital filter. 
First, we prewarp H(r,s) to obtain 


Hl(r,s) 


l 


l + a 


** n •> 

‘ n (r‘ 


+ s 2 ) n 


( 4 . 4 ) 


where 


a 2 - (-1 )/t«m 2 (RT/2) (4.5) 

(The assumption is made in this example that the 
sampling increment is the same In each direction and 
is equal to I.) Applying the bilinear 
transformation, we have an approximation for the 
ZW-Transiorm for the squared magnitude 
characteristic of the desired filter. 

1 (4.6) 

H(z,u) ” — j- 5 r- 

i+. 2 n K(*-i )/(*♦» )r+((w-i)/(w+orj n 


If the polynomial In the denominator of (4.6) 
were factorable Into distinct roots of z and w, then 
those roots vuuld occur in reciprocal pairs. The 
design procedure would then be completed by forming 
H(z,w) from those roots for which the magnitude of z 
is less than one and those for which the magnitude 
of w is less than one. The numerator polynomial of 
H(z,w) Is allowed to have roots with a magnitude of 
one. 


H(z,w) which is formed with the smaller in 
magnitude of each of the reciprocal pairs of roots 
in the numerator and denominator is said to have 
minimum phase. The minimum phase version of any 
filter is stable for any Inpul sequence unless the 
denominator of its ZW-Transform has roots where 
either the magnitude of z or w Is equal to one. In 
that case, it Is conditionally stable. 


where 


P 


( 2 a - (2 T "2 la + l ) 

1 - 2 a 


(4,8) 


5.0 FILTER DESIGN 
5. 1 Low Pass filter 

Equation (4.7) gives the ZW-Transform for the 
low pass filter approximation which was derived from 
the circularly symmetric low pass filter squared 
magnitude characteristic of (4.3). For this 
particular design, the roots oi l:(z,w) are real. In 
general, the roots may be real or they may occur in 
complex conjugate pair*' If the resulting filter is 
applied t a straightforward manner, the algorithm 
must handle complex numbers. This can be avoided by 
using a basic filter structure which uses only 
binomial functions resulting from the multiplication 
of two roots. When complex roots are Involved, the 
pair of complex conjugate roots would form a basic 
filter stage. The penalty paid for this basic 
filter structure Is that filters with odd numbers of 
zeroy or poles can only be Implemented by adding at 
least one null root. The addition cf this null root 
results in unnecessary calculations in the algorithm 
which implements the filter. Thus, all filters 
designed will have the basic structure: 

Ai(z 2 +q(l l)z+q(2i) ) [w 2 +q( 1 i)vfq(2 i) | 

H(z,w) -II r 5 (5.1) 

1 l z>p( 1 i) z+p( 2 1 ) J l wSp( ll)w+p( 2 i) J 

The basic low pass filter using this form is then 
given by 

(l+p)*(z 2 + 2 z+l )(u 2 +2w-M ) 

LP(z,w) - r : r- (5.2) 

16(z + 2 pz+p )(w^+ 2 pvr*-p ) 


3.2 The Frequency Boost Filter 

A irequency boost t’iltur con be designed from 
the nagnit ade response characteristics of rhe low 
pass filter. Con* Ider the filter which has a 
/.W- Transform given by: 

U(z,w) ■ c ♦* d | LP ( 2 , w) | ^ (5*3) 

Note tnat (5.1) has roots of * and of w with 
magnitude greater than one since the roots occur In 
reciprocal pairs. This problem is overcome by using 
the -ururaur phase version ot (5.3). Thus the 
CW- Transform ot the desired filter is given by: 

N(t.w) 

H(t.v) - (5.4) 

D( 2 ,v) 

where N(s.w) and D(z,w) have minimum phase. 

A high frequency boost filter can be designed 
by changing the values or c and d In (5.3). For the 
hi *!t pass r liter, r. nas a value of one and d has a 
value or minus one. If a low irequency boost rilter 
is desired with a magnitude gain of BF DC and a 
<,ain ot one at the Nyquist frequency, this can be 
achieved by setting: 

c « l • 0 

(5.5) 

d ■ BF - i.O 

If a ni ,h trequenev poost rilter is desired with a 
magnitude gain ot BF at the Nyquist irequency and a 
gain of one at PC, this can be achieved by setting: 

c * BF 

(5.6) 

d - 1.0 - jF 


The shape of the res/; ng filter is also 
affected by the value of the ro >t p which is derived 
Irom the design ot the low pass filter. From (4,7) 
and («.d), observe that o Is a function of the 
uesired radial cutoct frequency It, for the low pass 
filter. Note that three parameters, c, d and R, are 
required to design the filter specified by (5.3). 
However, if a high frequency boost or a low 
frequency boose filter Is desired, then only two 
parameters, K and BF are required because c and d 
can be derived i t om BF. 


6.0 FILTER DESIGN EXAMPLES 

Figure l gives the perspective plot of a 
lowj;us>:» .liter designee with Che described technique 
with a cut off irequency which Is 0.3 times the 
♦Nyquist frequency. Figure 2 gives the contour plot 
for this filter design. Figure 3 gives the 
perspective plot for a high frequency boost filter 
with a break frequency of 0.5 times the Nyquist 
frequency and a boost magnitude of 25.6. Figure 4 
gives the contour plot for this filter design. Note 
that these examples a**e essentially circularly 
symmetric. Some degradation Is observed as the 
break. frequency approaches the Nyquist frequency. 
Tills is caused by the mapping characteristics of the 
bilinear transformation. Some degradation also 
occurs as the break frequency approaches DC. 
However, this can be corrected by using rotated 
filter combinations (12j. 


7.0 CONCLUSION 

A design technique has been presented which can 
be used to design approximately circularly symmetric 
digital recursive filters for subjective image 
processing applications. These filters Include 
lowpass, highpass, low and high frequency boost and 
bandpass filters. The filters are inherently stable 
because the denominator polynomlnal of the 
ZW-Transf oru* ia minimum phase. 
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SIMULTANEOUS LINEAR ALGEBRAIC EQUATION FORMULATIONS OF 2D FILTERS 

D. E. OLSON, W. E. ALEXANDER, E. E. SHERROD 
Elec. Eng. Oept. , NC A&T SU, Greensboro, NC 

ABSTRACT 

It Is shown that 2D digital filter realizations are equivalent to the 
solution of tensor equations, and they are also equivalent to the solutim 
of mat 'x equations. Both recursible and non-recursible filters are 
included in these formulations. 


SUMMARY 

A 2D digital filter, which possesses a rational transfer function, may be 
represented by its bivariate difference equation written in tensor form as: 

b ij Vi.q+j * a U f P + i.q-*\j ^ 

where 1-p-N, l^q-M, -m-i-m, -m-j-m; and the double appearance of an indice 
on a given side of the equality implying the usual summation over the 
appropriate range of that indice. A more formal expression of (1) is: 


qkl _ _ A^l f 

B pq 9 kl ' A pq f kl 


( 2 ) 


where l-k^N, 1*1 S M, and the non-zero components of the coefficient tensors 
given by « k . Pil . q i and bJJ. b k _ p>1 . q ; for -mH-pfm, 

The 2D filtering operation requires that one determine all the gp^, given 

all a.., b. ., and f . A solution will exist and be unique if there exists 
ij U P<1 k i DQ 

an inverse of the tensor B pC| , say C^; with l^u^N, l^v^M. For such a case, 
the filtered solution would then be given by: 


’uv 


- c pq f 
uv M pq T kl 


(3) 


Tensor equation (2) can also be Interpreted as a matrix equation with the 
kl kl 

A ' , taken as NMxNM dimensional coefficient matrices with row index 

pq pq 

"pq" , column index "kl"; and g^ , f^ taken as column matrices. 


For the case when N=M, and agg, b Q g f 0; then equation (2) is also express- 
ible as a matrix equation involving only NxN matrices given by: 

m 


m 

LGR + £ 

k=-m,k^0 


S G T. « c PFQ + c Z S. F U. 

K k k=-m,k^0 K k 


(4) 


where c = a 0o /b oo’ the matrices G = ^ 9 pq^’ F = ^ f pq^ ; and tbe non ' zero 
components of the coefficient matrices L, R, P, Q, S^, T. and U. given by: 
(i) For p, q such that -m-q-p-m: 


L pq =b q-p,0 /b 00 ; 


R pq =b 0,q-p /b 00 ; 


P pq =a q-p,0 /a 00 ; 


%q~ a 0,q-p^ a 00’ 


T kpq" b k,p-q^ b 00 


‘ b k,0 b 0,p-q /b 00 ; 


U kpq =a k,p-q /a 00 


‘ a k,0 a 0,p-q /a 00‘ 


( ii) And finally, for p, q such that q-p=k: = 1. 

Non-recursible filters generally require solutions of the form given by (3). 
For recursible filters (4) simplifies allowing solution by compact schemes. 


